大神,Excel如何用VB在指定区域的单元格范围里面,每个单元格根据填写的内容,插入图片。 10
PrivateSubWorksheet_Change(ByValTargetAsRange)OnErrorResumeNextIfSelection.Count=1And...
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Selection.Count = 1 And Target.Address = "$B$2" Or Target.Address = "$B$3" Then
Dim fso, f, shp As Object
Dim rgTL As Range
Dim pname As String
pname = "c:\Project\pic\" & Range("B" & Target.Row).Value & ".jpg"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(pname) Then
For Each shp In ActiveSheet.Shapes
Set rgTL = shp.TopLeftCell
If rgTL.Row = IIf(Target.Row = 2, 1, 4) And rgTL.Column = 1 Then shp.Delete
Next
Set rgTL = Range("A" & IIf(Target.Row = 2, 1, 4))
Set shp = ActiveSheet.Pictures.Insert(pname)
shp.ShapeRange.Height = rgTL.Height
shp.Left = (rgTL.Width - shp.Width) / 2 + rgTL.Left
shp.Top = (rgTL.Height - shp.Height) / 2 + rgTL.Top
Else
MsgBox "不存在此名称的图片!"
GoTo e
End If
End If
e:
Set fso = Nothing
End Sub
看了之前的这段代码,但是不会改。 展开
On Error Resume Next
If Selection.Count = 1 And Target.Address = "$B$2" Or Target.Address = "$B$3" Then
Dim fso, f, shp As Object
Dim rgTL As Range
Dim pname As String
pname = "c:\Project\pic\" & Range("B" & Target.Row).Value & ".jpg"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(pname) Then
For Each shp In ActiveSheet.Shapes
Set rgTL = shp.TopLeftCell
If rgTL.Row = IIf(Target.Row = 2, 1, 4) And rgTL.Column = 1 Then shp.Delete
Next
Set rgTL = Range("A" & IIf(Target.Row = 2, 1, 4))
Set shp = ActiveSheet.Pictures.Insert(pname)
shp.ShapeRange.Height = rgTL.Height
shp.Left = (rgTL.Width - shp.Width) / 2 + rgTL.Left
shp.Top = (rgTL.Height - shp.Height) / 2 + rgTL.Top
Else
MsgBox "不存在此名称的图片!"
GoTo e
End If
End If
e:
Set fso = Nothing
End Sub
看了之前的这段代码,但是不会改。 展开
1个回答
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询