copy, paste, transpose rows with pictures

Question

I have a macro that copies and pastes rows from input sheet to output sheet. I find PRODUCT NAME and END DATE, then copy the whole row and transpose when pasting it. I am using transpose because I want to have vertical table.

I have a problem with images because I don't know how to copy them to proper cell so they match with Name and Date. I've managed to write a script that is copying and pasting images but it puts all of them in cell A1. When I want to add range to target_sheet.Paste I am getting vba method intersect of object _application failed error.

Below you can see how input and output sheets look.

Input sheet:

Expected output sheet (with only 3 columns) :

It is very important to know that 'input' sheet contains many products with names, prices and images and there is always a blank row between them. The number of images in each row can be different (from 1 to 25).

Sub copy_paste()

Dim Cell As Range
Dim src_rng As String
Dim LR As Long
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim pic As Shape

'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")

'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False

target_sheet.Cells.Delete
    'copy paste, transpose product line rows
    For Each Cell In source_sheet.Range(src_rng)
    LR = target_sheet.Range("A10000").End(xlUp).Row + 1
        If Cell.Value = "Name" Then
            Cell.EntireRow.Copy
            target_sheet.Range("A" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End If
    Next
    
    'copy paste, transpose end line rows
    For Each Cell In source_sheet.Range(src_rng)
        LR = target_sheet.Range("B10000").End(xlUp).Row + 1
        If Cell.Value = "Date" Then
            Cell.EntireRow.Copy
            target_sheet.Range("B" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        End If
    Next
    
    'copy paste image
    For Each Cell In source_sheet.Range(src_rng)
        LR = target_sheet.Range("C10000").End(xlUp).Row + 1
        If Cell.Value = "Image" Then
            For Each pic In source_sheet.Shapes
                If Not Application.Intersect(pic.TopLeftCell, Range(src_rng)) Is Nothing Then
                    pic.CopyPicture
                    target_sheet.Paste
                End If
            Next pic
        End If
    Next

Application.ScreenUpdating = True

End Sub

Answer 1

Please, try the next code. It follows the logic deduced from your last question edit, respectively: the former "Name" becomes "Product Name", "Date" becomes "End Date" and the row keeping the pictures is the one below "Product Name" row. It is able to process two or three product names/pictures per group:

Sub copy_paste()
 Dim Cell As Range, src_rng As String, LR As Long
 Dim source_sheet As Worksheet, target_sheet As Worksheet
 Dim pic As Shape, arrPAddr, rngTr As Range, k As Long
 Dim cellRHeight As Range, nrShapesPerRange As Long 'to be 2 or 3

 nrShapesPerRange = 2 'Choose here initial number of shapes per row (2 or 3)
 'worksheet with source data
 Set source_sheet = ThisWorkbook.Sheets("input")
 'worksheet with newly created template
 Set target_sheet =  ThisWorkbook.Sheets("output")

 'range of cells I want to check
 src_rng = "A14:A26"
 Application.ScreenUpdating = False
    ReDim arrPAddr(1 To 2, 1 To source_sheet.Shapes.count): k = 1
    target_sheet.cells.Delete: For Each pic In target_sheet.Shapes: pic.Delete: Next
    'copy paste, transpose product line rows
    For Each Cell In source_sheet.Range(src_rng)
        LR = target_sheet.Range("A" & rows.count).End(xlUp).row + 1
        If Cell.value = "Product Name" Then
            source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
            Set rngTr = target_sheet.Range("A" & LR)
            rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
            arrPAddr(1, k) = Cell.Offset(1, 1).Address
            arrPAddr(2, k) = rngTr.Offset(, 2).Address: k = k + 1
            arrPAddr(1, k) = Cell.Offset(1, 2).Address
            arrPAddr(2, k) = rngTr.Offset(1, 2).Address: k = k + 1
            If nrShapesPerRange = 3 Then
                arrPAddr(1, k) = Cell.Offset(1, 3).Address
                arrPAddr(2, k) = rngTr.Offset(2, 2).Address: k = k + 1
            End If
            If cellRHeight Is Nothing Then Set cellRHeight = Cell.Offset(1)
        End If
        LR = target_sheet.Range("B" & rows.count).End(xlUp).row + 1
        If Cell.value = "End Date" Then
            source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
            Set rngTr = target_sheet.Range("B" & LR)
            rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
        End If
    Next
    ReDim Preserve arrPAddr(1 To 2, 1 To k - 1)
    'Making the row height in target_sheet equal to source_sheet column with:
    target_sheet.Range("2:" & LR + 3).EntireRow.RowHeight = source_sheet.Range("A16").EntireRow.RowHeight
    target_sheet.Range("A:C").EntireColumn.AutoFit
    target_sheet.Range("C1").EntireColumn.ColumnWidth = cellRHeight.EntireColumn.ColumnWidth
    'copy paste image:
    Dim i As Long
    For Each pic In source_sheet.Shapes
        For i = 1 To UBound(arrPAddr, 2)
            If pic.TopLeftCell.Address = arrPAddr(1, i) Then
                pic.Copy: target_sheet.Paste
                With target_sheet.Shapes(target_sheet.Shapes.count)
                    .top = target_sheet.Range(arrPAddr(2, i)).top + (target_sheet.Range(arrPAddr(2, i)).RowHeight - pic.height) / 2
                    .left = target_sheet.Range(arrPAddr(2, i)).left
                End With
                Exit For
            End If
        Next i
    Next

 Application.ScreenUpdating = True
 target_sheet.Activate
 MsgBox "Ready..."
End Sub

Plese, test the code and send some feedback