Copy data using advanced filter across all sheets.

[Harshil Mehta]

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?

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
ws.Calculate
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


ThisWorkbook.Worksheets("Temp.Sheet").Cells.Clear

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, _
MatchCase:=False).Row


.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

Else

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.