Filter by a name in a column and paste the otput columns in another workbook using VBA

[RoseChapman]

Hi all, I hope you can help me. I am trying to filter by a name "Tree" in column "E", and add the values in columns of columns "B", "D", "G" in another spreadsheet ("Sheet5"). My code is shown below, which it does the filtering but it pastes Columns A to F and I would like to paste only columns B, D and G. Please see my code below. Your help would be very much appreciated. Many thanks. Rose

Sub Filtering()


Dim Lastrow As Long


With Sheets("DATA_Sheet")

If .Range("E:E").Find("Tree", , xlValues, xlWhole, , , False) Is Nothing Then
MsgBox "No ""Changed"" rows found. ", , "No Rows Copied": Exit Sub
Else

Application.ScreenUpdating = False
.Columns(7).Hidden = True
Lastrow = .Range("G" & Rows.Count).End(xlUp).Row
.Range("E1:E" & Lastrow).AutoFilter Field:=1, Criteria1:="Tree"
.Range("A1:G" & Lastrow).SpecialCells(xlCellTypeVisible).Copy

Sheets("Sheet5").Range("A:G").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
.AutoFilterMode = False

'Position on cell A4
With Application
.CutCopyMode = False

.Goto Sheets("Sheet5").Range("A:G")

.ScreenUpdating = True
End With
.Columns(7).Hidden = False
MsgBox "All matching data has been copied.", , "Copy Complete"

End If

End With


End Sub

 

[Fluff]

Hi & welcome to MrExcel
How about

Sub Filtering()
   Dim Lastrow As Long
   
   With Sheets("data_Sheet")
   
      If .Range("E:E").Find("Tree", , xlValues, xlWhole, , , False) Is Nothing Then
         MsgBox "No ""Changed"" rows found. ", , "No Rows Copied": Exit Sub
      End If
      
      Application.ScreenUpdating = False
      Lastrow = .Range("G" & Rows.Count).End(xlUp).row
      .Range("A1:G" & Lastrow).AutoFilter Field:=5, Criteria1:="Tree"
      Intersect(.AutoFilter.Range, .Range("B:B,D:D,G:G")).Copy
      
      Sheets("Sheet5").Range("A:G").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
      .AutoFilterMode = False
      
      'Position on cell A4
      With Application
         .CutCopyMode = False
         .Goto Sheets("Sheet5").Range("A:G")
         .ScreenUpdating = True
      End With
      MsgBox "All matching data has been copied.", , "Copy Complete"
      
   End With
End Sub

 

[RoseChapman]

Hello! thank you very much for the welcome, much appreciated!
You've made my day! this works now! you solve my problem!. I don't know how to thank you!. Great stuff! Thank you so much. My best regards to you

 

[Fluff]

Glad to help & thanks for the feedback

 

[RoseChapman]

Many thanks to you, a very well deserved feedback!