Copy data using advanced filter across all sheets.

Harshil Mehta

Board Regular
Joined
May 14, 2020
Messages
55
Office Version
  1. 2013
Platform
  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
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.
 
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

Threads
1,118,800
Messages
5,574,399
Members
412,589
Latest member
Velly
Top