VBA Filter Code - Image is not copied

Niveldor

New Member
Joined
Jan 18, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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?
 

Some videos you may like

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

Niveldor

New Member
Joined
Jan 18, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Attached see two images: One of the Source ("Sheet1") and the other of the Target Sheet ("Waterjet").
I hope this helps.
 

Attachments

  • Filter Code - Source Sheet.JPG
    Filter Code - Source Sheet.JPG
    94 KB · Views: 4
  • Filter Code - Target Sheet.JPG
    Filter Code - Target Sheet.JPG
    89.2 KB · Views: 4

Niveldor

New Member
Joined
Jan 18, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Below please find two images: the source sheet and the target sheet.
 

Attachments

  • Filter Code - Source Sheet.JPG
    Filter Code - Source Sheet.JPG
    94 KB · Views: 6
  • Filter Code - Target Sheet.JPG
    Filter Code - Target Sheet.JPG
    89.2 KB · Views: 6

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,714
Welcome to MrExcel forums.

Try this code, which expects the source sheet to be named "Source".
VBA Code:
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

New Member
Joined
Jan 18, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,714
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.

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,599
Messages
5,625,739
Members
416,132
Latest member
Chandan Choubey

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top