Copy Multiple Workbooks Data to the Masterfile based on Autofilter

Xlacs

Board Regular
Joined
Mar 31, 2021
Messages
105
Office Version
  1. 2016
Platform
  1. Windows
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.. =(

VBA Code:
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
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
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.
VBA Code:
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
 
Upvote 0
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.
VBA Code:
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.. =(
 
Upvote 0
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:
VBA Code:
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
 
Upvote 0
Hi john,

Im getting an error regarding this line.

Range("A8").CurrentRegion.AutoFilter

Out of range
 
Upvote 0
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 =(
 
Upvote 0

Forum statistics

Threads
1,213,492
Messages
6,113,967
Members
448,537
Latest member
Et_Cetera

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top