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
 
Sort by date Sort by votes

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
The macro works perfectly for me, and on multiple copies of your sample workbook. Is the data always in the first sheet? The (1) in this line means the macro filters the data in the first sheet: With fromWorkbook.Worksheets(1).

Here is the complete code I ran:
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"
    matchFiles = "C:\Temp\Draft?.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 between start date and end date
            .Range("B8").CurrentRegion.AutoFilter Field:=1, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
            If destCell.Row = 2 Then
                'Copy header row and data rows
                .Range("B8").CurrentRegion.Copy destCell.Offset(2)
            Else
                'Copy only data rows
                .Range("B8").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
Yes
John_w said:
The macro works perfectly for me, and on multiple copies of your sample workbook. Is the data always in the first sheet? The (1) in this line means the macro filters the data in the first sheet: With fromWorkbook.Worksheets(1).

Here is the complete code I ran:
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"
    matchFiles = "C:\Temp\Draft?.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 between start date and end date
            .Range("B8").CurrentRegion.AutoFilter Field:=1, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
            If destCell.Row = 2 Then
                'Copy header row and data rows
                .Range("B8").CurrentRegion.Copy destCell.Offset(2)
            Else
                'Copy only data rows
                .Range("B8").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
Click to expand...

Yes. Always in the first sheet. Will try this one
 
Upvote 0
John_w said:
The macro works perfectly for me, and on multiple copies of your sample workbook. Is the data always in the first sheet? The (1) in this line means the macro filters the data in the first sheet: With fromWorkbook.Worksheets(1).

Here is the complete code I ran:
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"
    matchFiles = "C:\Temp\Draft?.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 between start date and end date
            .Range("B8").CurrentRegion.AutoFilter Field:=1, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
            If destCell.Row = 2 Then
                'Copy header row and data rows
                .Range("B8").CurrentRegion.Copy destCell.Offset(2)
            Else
                'Copy only data rows
                .Range("B8").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
Click to expand...
Okay so Im getting closed to it. Thank you!

There are some issues tho I encoutered..

Like It should be pasted starting B of my masterfile and whenever I e xtracted again it will be pasted on the next available cell.
Also, this code matchFiles = "C:\Temp\Draft?.xlsm" only extracted my Draft workbook. when I changed this to matchFiles = "C:\Users\ChrisLacs\Desktop\My Files\*.xlsm" the error occur.

I uploaded my masterfile just in case. Sorry to bother you but can you take a look on this and try multiple workbooks if it works?

 
Upvote 0
John_w said:
The macro works perfectly for me, and on multiple copies of your sample workbook. Is the data always in the first sheet? The (1) in this line means the macro filters the data in the first sheet: With fromWorkbook.Worksheets(1).

Here is the complete code I ran:
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"
    matchFiles = "C:\Temp\Draft?.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 between start date and end date
            .Range("B8").CurrentRegion.AutoFilter Field:=1, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
            If destCell.Row = 2 Then
                'Copy header row and data rows
                .Range("B8").CurrentRegion.Copy destCell.Offset(2)
            Else
                'Copy only data rows
                .Range("B8").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
Click to expand...
Hi John,

Managed to fixed the issues, the only problem is, in my masterfile, it overlaps my header in masterfile.. i have a header in b1 of masterfile.if i start extracting, it should be in b2 onwards..
 
Upvote 0
Xlacs said:
Also, this code matchFiles = "C:\Temp\Draft?.xlsm" only extracted my Draft workbook
Click to expand...
It would extract only 1 file if there is only Draft.xlsm. I tested by creating multiple copies: Draft1.xlsm, Draft2.xlsm, Draft3.xlsm, which all match "Draft?.xlsm" - the ? wildcard character matches one or zero characters in that position.

Xlacs said:
in my masterfile, it overlaps my header in masterfile.. i have a header in b1 of masterfile.if i start extracting, it should be in b2 onwards..
Click to expand...
Try this macro. If there are no headers in row 1 starting at B1, or B1 is empty, the headers are copied from the first data file, along with the filtered data. If there are headers starting at B1 only the filtered data rows are copied.

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"
    'matchFiles = "D:\Temp\Excel\Workbooks\Draft?.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, "B").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 between start date and end date
           
            .Range("B8").CurrentRegion.AutoFilter Field:=1, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
           
            If destCell.Row = 1 Then
                'Copy header row and data rows
                .Range("B8").CurrentRegion.Copy destCell
            Else
                'Copy only data rows
                .Range("B8").CurrentRegion.Offset(1).Copy destCell
            End If
        End With
        fromWorkbook.Close False
       
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
       
        DoEvents
        fileName = Dir
    Wend
   
    Application.ScreenUpdating = True
   
    MsgBox "Finished"
   
End Sub
 
Upvote 0
Solution
John_w said:
It would extract only 1 file if there is only Draft.xlsm. I tested by creating multiple copies: Draft1.xlsm, Draft2.xlsm, Draft3.xlsm, which all match "Draft?.xlsm" - the ? wildcard character matches one or zero characters in that position.


Try this macro. If there are no headers in row 1 starting at B1, or B1 is empty, the headers are copied from the first data file, along with the filtered data. If there are headers starting at B1 only the filtered data rows are copied.

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"
    'matchFiles = "D:\Temp\Excel\Workbooks\Draft?.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, "B").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 between start date and end date
          
            .Range("B8").CurrentRegion.AutoFilter Field:=1, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
          
            If destCell.Row = 1 Then
                'Copy header row and data rows
                .Range("B8").CurrentRegion.Copy destCell
            Else
                'Copy only data rows
                .Range("B8").CurrentRegion.Offset(1).Copy destCell
            End If
        End With
        fromWorkbook.Close False
      
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
      
        DoEvents
        fileName = Dir
    Wend
  
    Application.ScreenUpdating = True
  
    MsgBox "Finished"
  
End Sub
Click to expand...

Oh my! This sealed it! Thanks a Lot for your time John! You are a savior.. =)
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA: All Sheets data to Master Sheet (excluding some sheet)
2
Replies
11
Views
390
kevin9999
K
B
  • 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
651
blackmamba89
B
S
  • Solved
VBA Code to select a variable folder path, find multiple .xls then copy same named worksheets into new workbook.
Replies
4
Views
433
SteveD01
S
O
  • Solved
Dependent dropdown list
Replies
1
Views
611
kevin9999
K
R
  • Question
VBA to Copy Multiple sheets to new workbook & save as .xlsb or .xlsx
2
Replies
16
Views
699
rahildhody
R

Forum statistics

Threads
1,214,968
Messages
6,122,509
Members
449,089
Latest member
RandomExceller01

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