импортировать несколько изображений в Excel и открыть файл на другом компьютере

Question

Мне удалось собрать некоторый код VBA из других источников (большое спасибо), чтобы создать что-то, что завершено примерно на 80%.Однако, когда я отправляю или открываю свою электронную таблицу на другом компьютере, мои изображения не отображаются (только красный крестик).

Мои исследования привели меня к использованию и вставке метода ActiveSheet.Shapes.AddPicture, однако я не уверен, как встроить это в мой функционирующий код / ​​где его разместить.У меня есть имена файлов в Column D, которые относятся к сохраненным изображениям из моей папки.Изображения загружаются в столбец C, и все это отлично работает, у меня есть около 550 файлов JPEG.Однако я не могу просматривать изображения, когда они выключены на моем компьютере

Мой рабочий код:

Sub InsertPicsr1Reg()
    Dim fPath As String, fName As String
    Dim r As Range
    Dim shp As Shape
    Application.ScreenUpdating = False
    fPath = "\Desktop\test workings\"
    For Each r In Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
        On Error GoTo errHandler
        If r.Value <> "" Then
            With ActiveSheet.Pictures.Insert(fPath & r.Value)
                .ShapeRange.LockAspectRatio = msoTrue
                .Top = Cells(r.Row, 3).Top
                .Left = Cells(r.Row, 3).Left
                If .ShapeRange.Width > Columns(3).Width Then .ShapeRange _
                    .Width = Columns(3).Width
                Rows(r.Row).RowHeight = .ShapeRange.Height
            End With
        End If
errHandler:
        If Err.Number <> 0 Then
            Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
            On Error GoTo -1
        End If
    Next r
    For Each shp In ActiveSheet.Shapes
        shp.Placement = xlMoveAndSize
    Next shp
    Application.ScreenUpdating = True
End Sub

Answer 1

попробуйте это:

Sub InsertPicsr1Reg()
Dim fPath As String, fName As String
Dim r As Range
Dim shp As Shape
Application.ScreenUpdating = False
fPath = "\Desktop\test workings\"
For Each r In Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
    If r.Value <> "" Then

        With ActiveSheet
            .Shapes.AddPicture fPath & r.Value, _
                msoFalse, msoTrue, _
                .Cells(r.Row, 3).Left, _
                .Cells(r.Row, 3).Top, _
                .Columns(3).Width, _
                .Rows(r.Row).Height
        End With

     end if
   next
end sub