Copy data using advanced filter across all sheets.

Harshil Mehta

Board Regular
May 14, 2020
Office Version
  1. 2013
  1. Windows
I am trying to create a macro which copies and pastes filtered data from all sheets of another workbook. The below code does the job but lacks accuracy in filtering data.

Please note the database range is same across all sheets of another workbook (Headers on Row no.7)

Accuracy Problem:
  1. It does not meet the criteria and pastes the entire data of sheet1 of the another workbook.
  2. Only the data of column A is pasted from other sheets, rest all the columns are blank.
Expectations: The code should search for the given criteria in each sheet of another workbook. If no data found then move to another sheet and paste the entire filtered data in this workbook.

Could anyone please help solve this?

VBA Code:
Sub Import_Data()

Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim x As Integer
Dim lcol, lrow As Long
Dim ws As Worksheet

Application.ScreenUpdating = False

For Each ws In Worksheets
Next ws

MsgBox ("1. Please select the LATEST time period file.")

FileToOpen = Application.GetOpenFilename(Title:="Browse for your file & import range", Filefilter:="Excel Files(.xls),xls")
If FileToOpen <> False Then

ThisWorkbook.Worksheets(10).Range(Cells(1, 9), Cells(Rows.Count, Columns.Count)).EntireColumn.Delete


Set OpenBook = Application.Workbooks.Open(FileToOpen)

With OpenBook

For Each ws In Worksheets

With ws

lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column

lrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _

.Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G27"), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7"), Unique:=False

End With

Next ws

End With

OpenBook.Close False


Exit Sub

End If

If WorksheetFunction.CountA(Sheets("Temp.Sheet").Range("A8:XFD18")) = 0 Then

Sheet10.Range(Cells(1, 9), Cells(Rows.Count, Columns.Count)).EntireColumn.Delete
MsgBox ("No data found as per the criteria.")
Exit Sub

End If
End Sub

Also asked here Copy data using advanced filter across all sheets.
Last edited by a moderator:

Some videos you may like

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

Watch MrExcel Video

Forum statistics

Latest member