Chirag R Raval
Member
Dear Sir @Marc L ,
(1) Re-upload code with un-comment on some lines.
(2) Where is criteria ?
(attached criteria's screen shot + ready made criteria excel file for just
copy paste criteria purpose in sheet 2).
(3) Attached 2 source file as sample (original each file have more then 50,000 lines so just some lines taken for just checking purpose. please change in criteria value for match with this 2 attached sample files for testing please put both in 1 folder & update path of that folder in code as target folder )
(3) Also attached where are error in code (Also Error Screen shot attached)
Code
Code:
'Testofadvfiltcopyinmaster
'LOOP IN FILES AND ADVANCE FILTER AND COPY TIO MASTER SHEET
Sub Test_of_Advfilt_Copy_in_Master()
Dim file As Variant
Dim path As String
Dim i As Integer
Dim wkbdest As Workbook
Dim wbksrs As Workbook
Dim Lastrow As Long
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' SET Which workbook Become Active & which will be open in Furutre
'Activate New, Unsaved , This Worbook & Will Be Use For Furute Re-activate It
'
Dim wkb As Workbook
For Each wkb In Workbooks
If Left(wkb.Name, 4) = "Book" Then
Set wkbdest = wkb
Else
Exit For
End If
wkb.Activate
Next wkb
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++
i = 2
path = ActiveSheet.range("a2").Value
If Right(path, 1) <> "\" Then path = path & "\"
file = Dir(path & "*.xls*")
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
ActiveSheet.range("V1:AL5").copy
While (file <> "")
For Each file In wkbdest.Sheets(1).range("a2")
If Error Then GoTo SkipFile
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Workbooks.Open path & file
Set wkbsrc = ActiveWorkbook
'
'++++++++++++++++++++++++++++++++++++++++++++++
'REQUIRE:- Advanced Filter here
Sheets(1).Activate
ActiveSheet.range("BB1").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.range("BB1").Select
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Advance filter on multiple critera here
Dim lrow As Long
Dim criteriarows As Long
Dim inputdatarange As range
Dim criteria_range As range
Dim rw As range
Dim criteria_header As range
Dim crange As range
Dim criteria As New Collection
With ActiveWorkbook.Sheets(1)
lrow = .Cells(Rows.count, 1).End(xlUp).Row
Set inputdatarange = .range("A1:AY" & lrow)
criteriarows = .range("BB" & Rows.count).End(xlUp).Row
Set criteria_range = .range("BB2:BB" & criteriarows).Resize(, 5)
Set crange = .range("BN1:BN2").Resize(, 5)
End With
Columns.AutoFit
For Each rw In criteria_range.Rows
If Error Then GoTo Skiprw
crange.Cells(2, 1).Resize(, 5) = rw.Value
inputdatarange.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=crange, Unique:=False
ActiveWorkbook.Sheets("Sheet1").range("A1:AY" & lrow).copy
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wkb.Activate
Sheets(1).Activate
With ActiveSheet
' If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
Lastrow = .Cells.Find(What:="*", _
After:=.range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
' End If
End With
ActiveSheet.Rows(Lastrow).Cells(2, 1).Select
ActiveSheet.Paste
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wkbsrc.Activate
Next rw
'End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Skiprw:
' Next rw
ActiveWorkbook.Close
' file = Dir()
Set wkbdest = Nothing
Set wbksrs = Nothing
Wend
SkipFile:
Next file
'Wend
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
