excel - 使用基于单元格值的文件路径导入多个图像

Question

我想根据“C”列中存在的文件路径导入多个图像。Jpeg 文件位于文件夹名称“FolderOf_Images”中，运行代码后它什么也不做，也没有引发错误。令人惊讶的是它只工作了一次，所有图片都导入了“D”列。图像文件将被放置在 D 列中。我尝试过的源代码如下，但没有成功。

Google 驱动程序 Excel 文件链接

Sub InsertPicsIntoExcel()
'Pictures saved with file
'Set column width (ie, pic width) before running macro
Application.ScreenUpdating = False
Dim r As Range, Shrink As Long
Dim shp As Shape
Shrink = 0 'Provides negative offset from cell borders when > 0

On Error Resume Next
''''Delete existing shapes/pictures
For Each shp In ActiveSheet.Shapes
    shp.Delete
Next shp
ActiveSheet.Rows.AutoFit

''''Insert shapes/pictures
For Each r In Range("C1:C" & Cells(Rows.Count, 1).End(xlUp).Row)
    If r.Value <> "" Then
        Set shp = ActiveSheet.Shapes.AddPicture(Filename:=r.Value, linktofile:=msoFalse, _
        savewithdocument:=msoTrue, Left:=Cells(r.Row, "D").Left + Shrink, _
        Top:=Cells(r.Row, "D").Top + Shrink, Width:=-1, Height:=-1)
        With shp
            
            .LockAspectRatio = msoTrue
            .Width = Columns(2).Width - (2 * Shrink)
            Rows(r.Row).RowHeight = .Height + (2 * Shrink)
        End With
    End If
Next r
Application.ScreenUpdating = True

MoveAndSizeWithCells

MsgBox ("Images Import Complete.")
End Sub



Sub MoveAndSizeWithCells()
    Dim xPic As Picture
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each xPic In ActiveSheet.Pictures
        xPic.Placement = xlMoveAndSize
    Next
    Application.ScreenUpdating = True
End Sub

标签： excelvba