Insert picture corresponding to cell value using excel macro

问题

I'm using the macro below to insert the picture corresponding to the value in Cell P2 into cell Q2.

This works for the one cell selected (P2 in this case).

I want to create a loop to do the same action for the rows in Column P range (P2:P500) that are not blank.

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 

回答1:

Try something along these lines. This is a very rough and ready solution, so you'll need to adapt it to your own requirements. Here I've put the image path in column B and is fired off from a CommandButton4 click. Not sure how you define your cell Left and Cell Top though?

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

回答2:

I use following, so the sheet can be mailed etc. : '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

来源：https://stackoverflow.com/questions/32815165/insert-picture-corresponding-to-cell-value-using-excel-macro