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

Question

我正在使用下面的宏将与单元格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 

Answer 1

尝试沿着这些线。这是一个非常粗糙和现成的解决方案，因此您需要根据自己的需求进行调整。在这里，我将图像路径放在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 

Answer 2

我使用后，使纸张可以邮寄等：

Picname in Column B7 and corresponding picture in Column 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