Option Explicit
'Testofadvfiltcopyinmaster
'LOOP IN FILES AND ADVANCE FILTER AND COPY TIO MASTER SHEET FOR SUITING INVOICE INFORMATION
'WARNING :- FIRST RUN READY MADE CRITERA MACRO FOR READY MADE CRITERA STRUCTURE
'SUITING INVOICE INFORMATION
Sub StgLoopFileAdvfilt_CopyinMaster()
Dim wkbDest As Workbook
Dim wkbSource As Workbook
' Set wkbDest = ThisWorkbook
Set wkbDest = ActiveWorkbook
Dim LastRow As Long
Dim StrMyPath As String
StrMyPath = ActiveSheet.range("A2").Value 'change folder path to suit your needs
Dim strFileAndExt As String
' StrMyPath = ActiveSheet.range("A2").text 'change folder path to suit your needs
' StrMyPath = "D:\INV INFO 46 COLUMNS ALL GUJARAT-MONTH WISE EXCEL FILE-2017" 'change folder path to suit your needs
If Right(StrMyPath, 1) <> "\" Then
StrMyPath = StrMyPath & "\"
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
ChDir StrMyPath
strFileAndExt = Dir(StrMyPath & "*.xl*")
Do While strFileAndExt <> ""
' Set wkbDest = ThisWorkbook
Set wkbDest = ActiveWorkbook
wkbDest.Activate
ActiveSheet.range("I1:T5").Copy
Set wkbSource = Workbooks.Open(StrMyPath & strFileAndExt)
' Application.Wait Now + TimeValue("00:00:01") 'FILE KHULE TYAN SUDHI RAAH JOSE
' DoEvents 'Ensure Workbook has opened before moving on to next line of code
On Error GoTo Skip
With wkbSource
'
Sheets(1).Activate
''++++++++++++++++++++++++++++++++++++++++++++++
'REQUIRE:- Advanced Filter here
ActiveSheet.range("BN1").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.range("BN1").Select
End With
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Advance filter on multiple critera here
Dim lRow As Long
Dim i As Integer
Dim criteriarows As Long
Dim inputdatarange As range
Dim criteria_range As range
Dim rw As Variant
Dim criteria_header As range
Dim crange As range
Dim criteria As New Collection
With ActiveWorkbook.Sheets(1)
If .AutoFilterMode Then .Cells.AutoFilter
lRow = .Cells(Rows.count, 1).End(xlUp).Row
Set inputdatarange = .range("A1:BL" & lRow)
criteriarows = .range("BN" & Rows.count).End(xlUp).Row
Set criteria_range = .range("BN2:BN" & criteriarows).Resize(, 5)
Set crange = .range("BU1:BU2").Resize(, 5)
End With
On Error GoTo Skip
For Each rw In criteria_range.Rows
crange.Cells(2, 1).Resize(, 5) = rw.Value
inputdatarange.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=crange, Unique:=False
' ActiveWorkbook.Sheets("Sheet1").range("A2:A" & lRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
ActiveWorkbook.Sheets(1).range("A1:BL" & lRow).Copy
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wkbDest.Activate
Sheets(2).Activate
With ActiveSheet
range("A1").Select
Selection.End(xlDown).offset(1, 0).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wkbSource.Activate
Next rw
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Skip:
Resume Next
'Next wkbSource
Resume Next
'End With
wkbSource.Close SaveChanges:=False
DoEvents
' Application.Wait Now + TimeValue("00:00:01")
'Get next file name
strFileAndExt = Dir
Set wkbDest = Nothing
Set wkbSource = Nothing
Loop
'
Cells.WrapText = False
Cells.EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
