Copy Multiple Workbooks Data to the Masterfile based on Autofilter

X

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

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
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
John_w said:
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
Click to expand...

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
Xlacs said:
My external workbooks has dates starting B9. B8 is the header..
If I use A1 and A2 as date range is this possible??
Click to expand...
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
John_w said:
Change the 3 occurrences of A8 to B8 and Field to 1.
Click to expand...
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
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA: All Sheets data to Master Sheet (excluding some sheet)
2
Replies
11
Views
769
kevin9999
K
B
  • Question Question
Copying data from one sheet, pasting into another then based on criteria in that sheet pasting other data into new sheet
Replies
0
Views
763
blackmamba89
B
B
  • Question Question
Copy and paste from one worksheet into a new workbook and save to a particular directory
Replies
3
Views
730
Joe4
Joe4
J
  • Solved
EXCEL VBA - help to copy filtered data from one workbook to multiple new workbooks and save code.
Replies
2
Views
446
Jordan2
J
D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
338
RoryA
RoryA

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

Share this page

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