Блог

Я хочу импортировать несколько изображений на основе пути к файлу, присутствующего в столбце «C». Файлы Jpeg находятся в папке с именем «FolderOf_Images», и при запуске кода он ничего не делает, а также ошибка не была выдана. На удивление, это сработало только один раз, и все изображения были импортированы в столбец «D». Файлы изображений будут помещены в столбец D. Исходный код, который я пробовал, приведен ниже, но безуспешно.

Google driver Ссылка на файл 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" amp; 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