Question

我使用下面的宏将与Cell 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点击中触发。不知道你如何定义你的细胞Left和Cell Top？

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

我使用以下，所以可以邮寄纸张等： '列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

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

2 个答案: