Copying pictures to corresponding cell in destination workbook

Question

I am trying to compile some spreadsheets into a destination workbook.

I failed getting pictures into the new workbook.

I researched arrays and collections but my implementations have many errors and I got rid of the code.

I added Application.CopyObjectsWithCells = True but it has no effect on the pictures.

Here is code that works. What can I add to bring pictures over?

Private Sub btnStitchData_Click()
Dim dsh As Worksheet
Dim sh As Worksheet
Dim wb As Workbook
Dim n As Long

Dim blnCountingInit As Boolean

Dim fso As New FileSystemObject
Dim fo As Folder
Dim x As File

Application.DisplayAlerts = False
Application.CopyObjectsWithCells = True

Set fo = fso.GetFolder("C:\Users\PCCSa\Documents\PCC\Workbooks\Compiler")
Set dsh = ThisWorkbook.Sheets("Compile Test")

For Each x In fo.Files
    Set wb = Workbooks.Open(x.Path)
    Set sh = wb.Sheets("Invoice")
    
    If blnCountingInit = False Then
        n = dsh.Range("A1" & Application.Rows.Count).End(xlUp).Row
        sh.UsedRange.Copy
        dsh.Range("A1" & n).PasteSpecial xlPasteAllUsingSourceTheme
        blnCountingInit = True

    Else
        sh.Range("A15").Select
        sh.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        sh.UsedRange.Copy
        dsh.Range("A1" & n).PasteSpecial xlPasteAll
    End If
    
    wb.Close False

Next

End Sub

My goal is to copy the cells from the first spreadsheets, paste it, then start on a specified row (A15) for all other sheets to be copied.

The pictures (shapes/objects?) in this sheet need to be pasted in the corresponding cell they come from in the source spreadsheets.

Answer 1

Below is a sub procedure that you could include in your code to copy pictures from a range into another range and respect the relative position of the pictures in the source range.

This macro loops over all the pictures in the sheet where the source range (first argument) is located and it checks if each picture's top left corner is inside that range. This is not perfect since you might want to exclude pictures that are don't fit fully inside the range (see image below), but I figured it's probably enough for your use case.

For example if the source picture range is the used range:

The macro will then paste the picture and reposition it relative to the cell that you provided for the second argument to make sure that pictures will have the same relative position after being pasted.

Here is the code for the sub procedure:

Sub CopyPicturesInsideRange(ByRef SrcPictRange As Range, ByRef DestTopLeftCell As Range)

    Dim shp As Shape
    For Each shp In SrcPictRange.Parent.Shapes

        If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then

            If SrcPictRange.Top <= shp.Top And shp.Top <= SrcPictRange.Top + SrcPictRange.Height Then

                If SrcPictRange.Left <= shp.Left And shp.Left <= SrcPictRange.Left + SrcPictRange.Width Then

                    shp.Copy

                    Dim dws As Worksheet
                    Set dws = DestTopLeftCell.Parent

                    dws.Parent.Activate
                    dws.Activate
                    dws.Paste

                    Dim NewShape As Picture
                    Set NewShape = Selection

                    Dim OriginalTopOffset As Double, OriginalLeftOffset As Double
                    OriginalTopOffset = shp.Top - SrcPictRange.Top
                    OriginalLeftOffset = shp.Left - SrcPictRange.Left

                    NewShape.Top = DestTopLeftCell.Top + OriginalTopOffset
                    NewShape.Left = DestTopLeftCell.Left + OriginalLeftOffset

                End If

            End If

        End If
    Next shp
End Sub

So, to include it in your code, you would simply replace the If-statement that you had with something like this:

    If blnCountingInit = False Then
        n = dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
        sh.UsedRange.Copy
        dsh.Range("A" & n + 1).PasteSpecial xlPasteAllUsingSourceTheme

        CopyPicturesInsideRange sh.UsedRange, dsh.Range("A" & n + 1)

        blnCountingInit = True

    Else
        n = dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
        sh.Range(sh.Range("A15"), sh.Cells.SpecialCells(xlLastCell)).Copy
        dsh.Range("A" & n + 1).PasteSpecial xlPasteAll

        CopyPicturesInsideRange sh.Range(sh.Range("A15"), sh.Cells.SpecialCells(xlLastCell)), dsh.Range("A" & n + 1)

    End If