Copy Multiple Workbooks Data to the Masterfile based on Autofilter

[Xlacs]

Hi Good People,

To make it short, so I have this Masterfile called Archive with extraction button and I have multiple workbooks (20+).
In my Masterfile A1 field when I typed a particular date. (e.g. A1 = 21-May) and click Run. All my my workbooks(20+) will be filtered and copy all the data to my mastefile next available cell.

But I am nowhere near of that possibility. Hoping someone could actually assist me on doing this.. =(

Sub CopyRows()
    
    ' Source
    Const sFolderPath As String = "C:\Users\ChrisLacs\Desktop\My Files\"
    Const sFilePattern As String = "*.xlsm*"
    Const sName As String = "Sheet1"
    Const sAddress As String = "B200:N200"
    ' Destination
    Const dCol As String = "B"
    
    Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
    If Len(sFileName) = 0 Then
        MsgBox "No files matching the pattern '" & sFilePattern _
            & "'" & vbLf & "found in '" & sFolderPath & "'.", vbExclamation
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = Sheet4.Parent
    Dim dFileName As String: dFileName = dwb.Name
    Dim dCell As Range
    Set dCell = Sheet4.Cells(Sheet4.Rows.Count, dCol).End(xlUp).Offset(1)
    Dim drg As Range
    Set drg = dCell.Resize(, Sheet4.Range(sAddress).Columns.Count)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim fCount As Long
    
    Do Until Len(sFileName) = 0
        If StrComp(sFileName, dFileName, vbTextCompare) <> 0 Then
            Set swb = Workbooks.Open(sFolderPath & sFileName)
            On Error Resume Next ' attenpt to reference the source worksheet
                Set sws = swb.Worksheets(sName)
            On Error GoTo 0
            If Not sws Is Nothing Then ' source worksheet found
                Set srg = sws.Range(sAddress)
                ' Either copy values, formulas, formats...
                srg.Copy drg
                ' ... or instead copy only values (more efficient (faster))
                'drg.Value = srg.Value
                Set drg = drg.Offset(1)
                Set sws = Nothing
                fCount = fCount + 1
            'Else ' source worksheet not found; do nothing
            End If
            swb.Close SaveChanges:=False
        End If
        sFileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "Rows copied: " & fCount, vbInformation
    
End Sub

 

[John_w]

You haven't said which column in the external multiple workbooks should be filtered by the date in A1. This macro filters column A by the date (.UsedRange.AutoFilter Field:=1).

The A1 date value in the master workbook should be in the active sheet and the external filtered data is imported starting at the next available cell in column A of the active sheet, with a blank row above, e.g A3. Column headings are imported from the first external workbook.

Option Explicit

Public Sub Copy_AutoFiltered_Rows_From_Workbooks()

    Dim matchFiles As String, folder As String, fileName As String
    Dim destCell As Range
    Dim fromWorkbook As Workbook
    Dim filterDate As Date
    
    'Folder and wildcard file spec of workbooks to import
    
    matchFiles = "C:\Users\ChrisLacs\Desktop\My Files\*.xlsm"

    folder = Left(matchFiles, InStrRev(matchFiles, "\"))
    
    With ThisWorkbook.ActiveSheet
        If Not IsDate(.Range("A1").Value) Or IsEmpty(.Range("A1").Value) Then
            MsgBox "Cell A1 must contain a date"
            Exit Sub
        End If
        filterDate = .Range("A1").Value
        Set destCell = .Cells(.Rows.Count, "A").End(xlUp)
    End With
    
    Application.ScreenUpdating = False
    
    fileName = Dir(matchFiles)
    While fileName <> vbNullString
        Set fromWorkbook = Workbooks.Open(folder & fileName, ReadOnly:=True)
        With fromWorkbook.Worksheets(1)
            'Filter column A by date           
            .UsedRange.AutoFilter Field:=1, Criteria1:=">=" & CLng(filterDate), Operator:=xlAnd, Criteria2:="<=" & CLng(filterDate)
            
            If destCell.Row = 1 Then
                'Copy header row and data rows
                .UsedRange.Copy destCell.Offset(2)
            Else
                'Copy only data rows
                .UsedRange.Offset(1).Copy destCell
            End If
        End With
        fromWorkbook.Close False
        
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
        
        DoEvents
        fileName = Dir
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "Finished"
    
End Sub

 

[Xlacs]

You haven't said which column in the external multiple workbooks should be filtered by the date in A1. This macro filters column A by the date (.UsedRange.AutoFilter Field:=1).

The A1 date value in the master workbook should be in the active sheet and the external filtered data is imported starting at the next available cell in column A of the active sheet, with a blank row above, e.g A3. Column headings are imported from the first external workbook.

Option Explicit

Public Sub Copy_AutoFiltered_Rows_From_Workbooks()

    Dim matchFiles As String, folder As String, fileName As String
    Dim destCell As Range
    Dim fromWorkbook As Workbook
    Dim filterDate As Date
   
    'Folder and wildcard file spec of workbooks to import
   
    matchFiles = "C:\Users\ChrisLacs\Desktop\My Files\*.xlsm"

    folder = Left(matchFiles, InStrRev(matchFiles, "\"))
   
    With ThisWorkbook.ActiveSheet
        If Not IsDate(.Range("A1").Value) Or IsEmpty(.Range("A1").Value) Then
            MsgBox "Cell A1 must contain a date"
            Exit Sub
        End If
        filterDate = .Range("A1").Value
        Set destCell = .Cells(.Rows.Count, "A").End(xlUp)
    End With
   
    Application.ScreenUpdating = False
   
    fileName = Dir(matchFiles)
    While fileName <> vbNullString
        Set fromWorkbook = Workbooks.Open(folder & fileName, ReadOnly:=True)
        With fromWorkbook.Worksheets(1)
            'Filter column A by date          
            .UsedRange.AutoFilter Field:=1, Criteria1:=">=" & CLng(filterDate), Operator:=xlAnd, Criteria2:="<=" & CLng(filterDate)
           
            If destCell.Row = 1 Then
                'Copy header row and data rows
                .UsedRange.Copy destCell.Offset(2)
            Else
                'Copy only data rows
                .UsedRange.Offset(1).Copy destCell
            End If
        End With
        fromWorkbook.Close False
       
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
       
        DoEvents
        fileName = Dir
    Wend
   
    Application.ScreenUpdating = True
   
    MsgBox "Finished"
   
End Sub

Hi John.

Thank you for noticing my post

My external workbooks has dates starting B9. B8 is the header..
If I use A1 and A2 as date range is this possible??
LIke for example. I A1 value = 01-May and A2 value is 15-May.. 1-15 May will be extracted..

I tried to modify (.UsedRange.AutoFilter Field:=1). to (.UsedRange.AutoFilter Field:=2).

But its giving me an error.. =(

 

[John_w]

My external workbooks has dates starting B9. B8 is the header..
If I use A1 and A2 as date range is this possible??

Try this modified macro:

Public Sub Copy_AutoFiltered_Rows_From_Workbooks()

    Dim matchFiles As String, folder As String, fileName As String
    Dim destCell As Range
    Dim fromWorkbook As Workbook
    Dim startDate As Date, endDate As Date
    
    'Folder and wildcard file spec of workbooks to import
    
    matchFiles = "C:\Users\ChrisLacs\Desktop\My Files\*.xlsm"
    folder = Left(matchFiles, InStrRev(matchFiles, "\"))
    
    With ThisWorkbook.ActiveSheet
        If Not IsDate(.Range("A1").Value) Or IsEmpty(.Range("A1").Value) Or Not IsDate(.Range("A2").Value) Or IsEmpty(.Range("A2").Value) Then
            MsgBox "Cells A1 and A2 must contain a date"
            Exit Sub
        End If
        startDate = .Range("A1").Value
        endDate = .Range("A2").Value
        If startDate > endDate Then
            MsgBox "Start date in A1 must be earlier than end date in A2"
            Exit Sub
        End If
        Set destCell = .Cells(.Rows.Count, "A").End(xlUp)
    End With
    
    Application.ScreenUpdating = False
    
    fileName = Dir(matchFiles)
    While fileName <> vbNullString
        Set fromWorkbook = Workbooks.Open(folder & fileName, ReadOnly:=True)
        With fromWorkbook.Worksheets(1)
            'Filter column B by between start date and end date
            .Range("A8").CurrentRegion.AutoFilter Field:=2, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
            
            If destCell.Row = 2 Then
                'Copy header row and data rows
                .Range("A8").CurrentRegion.Copy destCell.Offset(2)
            Else
                'Copy only data rows
                .Range("A8").CurrentRegion.Offset(1).Copy destCell
            End If
        End With
        fromWorkbook.Close False
        
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
        
        DoEvents
        fileName = Dir
    Wend
    
    Application.ScreenUpdating = True
    
    MsgBox "Finished"
    
End Sub

 

[Xlacs]

Hi john,

Im getting an error regarding this line.

Range("A8").CurrentRegion.AutoFilter

Out of range

 

[John_w]

Do the data headers start in A8 or B8?

 

[Xlacs]

Do the data headers start in A8 or B8?

Starts in B8. Eventho i amended it to B8. Still an error

 

[John_w]

Change the 3 occurrences of A8 to B8 and Field to 1.

 

[Xlacs]

Same error autofilter

 

[Xlacs]

Change the 3 occurrences of A8 to B8 and Field to 1.

Hi john.

Just to give you an idea regarding the error. Autofilter method of range class failed. I have upload an image of my masterfile and one of my workbook source.. Appreciate your help on this =(