Vba 使用excel宏插入与单元格值对应的图片

我正在使用下面的宏将与单元格P2中的值对应的图片插入单元格Q2

在本例中，这适用于所选的一个单元格P2

我想创建一个循环，对p列范围P2:P500中非空的行执行相同的操作

Sub Picture()

 Range("Q2").Select 
 Dim picname As String

 picname = "C:\Users\kisnahr\Pictures\Test\" & Range("P2") & ".bmp" 'Link to the picture
 ActiveSheet.Pictures.Insert(picname).Select

 With Selection
 .Left = Range("Q2").Left
 .Top = Range("Q2").Top
 .ShapeRange.LockAspectRatio = msoFalse
 .ShapeRange.Height = 80#
 .ShapeRange.Width = 80#
 .ShapeRange.Rotation = 0#
 End With

 Range("Q10").Select
 Application.ScreenUpdating = True

 Exit Sub

 ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
 Exit Sub
 Range("P20").Select

 End Sub 

---

试着用这些方法。这是一个非常粗略和现成的解决方案，因此您需要根据自己的需求对其进行调整。在这里，我将图像路径放在B列中，并通过CommandButton4单击触发。不知道如何定义左单元格和上单元格

Private Sub CommandButton4_Click()
 Dim MyRange As String
 Dim picname As String
 Dim mySelectRange As String
 Dim rcell As Range
 Dim IntInstr As Integer
 Dim Mypath As String

 Mypath = "z:\My Pictures"
 MyRange = "B2:B500"

 Range(MyRange).Select
 For Each rcell In Selection.Cells
    If Len(rcell.value) > 0 Then
        picname = Mypath & rcell.value
        mySelectRange = Replace(MyRange, "B", "A")
        IntInstr = InStr(mySelectRange, ":")
        mySelectRange = Left(mySelectRange, IntInstr - 1)
        do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
     End If
Next
Application.ScreenUpdating = True
End Sub

Private Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    ActiveSheet.Pictures.Insert(picname).Select
    On Error GoTo 0

    With Selection
     .Left = myleft
     .Top = mytop
     .ShapeRange.LockAspectRatio = msoFalse
     .ShapeRange.Height = 80#
     .ShapeRange.Width = 80#
     .ShapeRange.Rotation = 0#
    End With
Exit Sub
ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub

---

我使用以下方法，因此可以邮寄表格等： 'B7列中的Picname和M7列中的相应图片

Sub Picture()
    Dim picname As String
    Dim shp As Shape
    Dim pasteAt As Integer
    Dim lThisRow As Long

    lThisRow = 7 'This is the start row

    Do While (Cells(lThisRow, 2) <> "")


        pasteAt = lThisRow
        Cells(pasteAt, 13).Select 'This is where picture will be inserted (column)


        picname = Cells(lThisRow, 2) 'This is the picture name

        present = Dir("C:\foto\" & picname & ".jpg")

        If present <> "" Then

            Cells(pasteAt, 13).Select

            Call ActiveSheet.Shapes.AddPicture("C:\foto\" & picname & ".jpg", _
            msoCTrue, msoCTrue, Left:=Cells(pasteAt, 13).Left, Top:=Cells(pasteAt, 13).Top, Width:=100, Height:=100).Select


        Else
            Cells(pasteAt, 14) = "No Picture Found"
        End If

        lThisRow = lThisRow + 1
    Loop

    Range("A1").Select
    Application.ScreenUpdating = True

    Exit Sub

ErrNoPhoto:
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found
    Exit Sub
    Range("O7").Select

End Sub

---

嗨，米格尔，非常感谢你的帮助！这工作得很好，我能够循环输入范围并插入本地驱动器中的图片。但是，图片被插入到与我的输入范围相同的列中，我无法将其更改为行中的下一个单元格。例如，如果MyRange为B2:B500，则相应的图片将插入到相同的单元格中。如果希望图片位于文件名的左侧，则将do_insertPic调用中的rcell.left替换为数字1。如果你想让它在右边，那么使用一个大约200-250的值。谢谢！您能否指导我如何使用单元格ID在任何指定的单元格中添加图片？例如，如果我想将单元格B2中的图片名称添加到单元格T2，将单元格B3中的图片名称添加到单元格T3。实际上，将图片嵌入单元格是困难的。这里有一个完整的讨论[我唯一的技巧是记录一个宏，如果您编辑宏并将其与代码中已用于定位图像的B列顶部度量一起使用，则可以看到T列的左侧度量值。