使用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