动态图片循环

Question

因此，我已经创建了一个动态选择列表的excel使用vba。见下文

​

​

​

​

下面是代码

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
    Call PanggilPhoto
End If
End Sub


Sub PanggilPhoto()
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T As String


myDir = ThisWorkbook.Path & "\"
CommodityName1 = Range("A2")
T = ".png"

Range("C15").Value = CommodityName
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=190, Top:=10, Width:=140, 
Height:=90

errormessage:If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the Commodity!"
Range("A2").Value = ""
Range("C10").Value = ""

End If
Application.ScreenUpdating = True
End Sub

foto是工作表中的预定义数据列表。

所以问题是，与其为一个细胞做这件事，我还能为多个细胞创建一个循环吗？我需要它在一个宏运行时导入多个图像。

​

​

Answer 1

找到解决办法

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    If Target.Address = "$A$2" Then
        Call schedules
    End If
End Sub

Sub schedules()

Worksheets("Picture").Activate





Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next

Dim CommodityName1 As String, CommodityName2 As String, T1 As String, T2 As String
Dim i As Integer, j As Integer, k As Integer

j = 0



For i = 2 To 100




myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
CommodityName1 = Range("A" & i)
T1 = ".png"




On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T1, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=230, Top:=j, Width:=140, Height:=80



errormessage:
If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
Range("A" & i).Value = ""
Range("C10").Value = ""

End If
Application.ScreenUpdating = True
i = i + 11
j = j + 190
Next i


End Sub