VBA Filter Code - Image is not copied

[Niveldor]

I wrote a code to take a list of data from one Sheet to another but only place data that falls under specific criteria. it works fine but it transfer only data and not the images that are in some of the cells.
My code looks like the following:

Sub Worksheet_Activate()
Range("A4:K2000").Select
Selection.ClearContents

Range("D1").Select
i = 4
j = 4
While i <= 2000

If Worksheets("Sheet1").Cells(i, 7) = "Waterjet" Then

p = Worksheets("Sheet1").Cells(i, 1)
q = Worksheets("Sheet1").Cells(i, 2)
r = Worksheets("Sheet1").Cells(i, 3)
s = Worksheets("Sheet1").Cells(i, 4)
t = Worksheets("Sheet1").Cells(i, 5)
u = Worksheets("Sheet1").Cells(i, 6)
v = Worksheets("Sheet1").Cells(i, 7)
w = Worksheets("Sheet1").Cells(i, 8)
x = Worksheets("Sheet1").Cells(i, 9)
y = Worksheets("Sheet1").Cells(i, 10)
Z = Worksheets("Sheet1").Cells(i, 11)

Cells(j, 1) = p
Cells(j, 2) = q
Cells(j, 3) = r
Cells(j, 4) = s
Cells(j, 5) = t
Cells(j, 6) = u
Cells(j, 7) = v
Cells(j, 8) = w
Cells(j, 9) = x
Cells(j, 10) = y
Cells(j, 11) = Z

j = j + 1

Else
End If
i = i + 1

Wend

End Sub

Why the pictures in cell "q" from Worksheets("Sheet1").Cells(i, 2) are not being pasted into Cells(j, 2) = q in the Active Sheet?

 

[Niveldor]

Attached see two images: One of the Source ("Sheet1") and the other of the Target Sheet ("Waterjet").
I hope this helps.

 

[Niveldor]

Below please find two images: the source sheet and the target sheet.

 

[John_w]

Welcome to MrExcel forums.

Try this code, which expects the source sheet to be named "Source".

Private Sub Worksheet_Activate()

    Dim r As Long, lastRow As Long, destRow As Long
    Dim shp As Shape
    
    Application.ScreenUpdating = False
    
    With Me
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow >= 4 Then .Range("A4", .Cells(lastRow, "K")).ClearContents
        For Each shp In .Shapes
            shp.Delete
        Next
        destRow = 4
    End With
    
    With Worksheets("Source")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 4 To lastRow
            If .Cells(r, "G").Value = "Waterjet" Then
                .Range("A" & r & ":K" & r).Copy Me.Cells(destRow, "A")
                destRow = destRow + 1
            End If
        Next
    End With
    
    Application.ScreenUpdating = True

End Sub

 

[Niveldor]

John_w -
Thank you for the support. The code your wrote is a good start. When I ran it some pictures were placed in the wrong place, some are sitting one on top of another and some parts that are not "Waterjet" went to the Active Sheet.
Can you see what is the reason?
Thanks, Niv

 

[John_w]

Copying a range which includes a picture is tricky because the picture (shape) is placed on top of the cell, not actually in it. I don't see how some rows that are not "Waterjet" are copied to the active sheet because this line specifically looks in column G of the Source sheet: If .Cells(r, "G").Value = "Waterjet" Then

Try this alternative method which, instead of copying the whole row (columns A:K) in one go, copies the column A cell value, then C:K cell values, then the picture via Copy/Paste to the column B cell.

Private Sub Worksheet_Activate()

    Dim r As Long, lastRow As Long, destRow As Long
    Dim shp As Shape
    Dim currentCell As Range
    
    Application.ScreenUpdating = False
    
    With Me
        Set currentCell = ActiveCell
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow >= 4 Then .Range("A4", .Cells(lastRow, "K")).ClearContents
        For Each shp In .Shapes
            shp.Delete
        Next
        destRow = 4
    End With
    
    With Worksheets("Source")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 4 To lastRow
            If .Cells(r, "G").Value = "Waterjet" Then
                Me.Cells(destRow, "A").Value = .Range("A" & r).Value
                Me.Range("C" & destRow & ":K" & destRow).Value = .Range("C" & r & ":K" & r).Value
                
                'Find first shape in row r of Source sheet and copy it to row destRow column B of this sheet
                For Each shp In .Shapes
                    If shp.TopLeftCell.Row = r Then
                        shp.Copy
                        Me.Paste
                        'Place shape in top-left of column B cell
                        Me.Shapes(Me.Shapes.Count).Top = Me.Cells(destRow, "B").Top
                        Me.Shapes(Me.Shapes.Count).Left = Me.Cells(destRow, "B").Left
                        Exit For
                    End If
                 Next
                 
                destRow = destRow + 1
            End If
        Next
    End With
    
    currentCell.Select
    
    Application.ScreenUpdating = True

End Sub