Loop through files in a folder and copy data into a Master Sheet based on criteria

Bering

Board Regular
Joined
Aug 22, 2018
Messages
125
Office Version
  1. 2016
Platform
  1. Windows
Hello,

I use the macro below to loop through all the xlsx files with a certain name in a folder and to copy paste data from a sheet called Exchange rates into a Sheet1 of the the master file (Thisworkbook).

There are many different files in the folder, however I am only interested in those called "NAV_PACK_L3264_YYYYMMDD", which are automatically saved in that location on a daily basis.

So far I managed to retrieve the data from all the files for 2020 (If Left(strFile, 19) = "NAV_PACK_L3264_2020" Then), however what I would really like to achieve is extracting the information only for a specific quarter plus the last day of the previous quarter. Example: for Q1 2020 I would need to extract the data from all daily reports from 31/12/2019 to 31/03/2020, for Q2 2020 I would need to extract the data from all daily reports from 31/03/2020 to 30/06/2020.


Is there any way I could accomplish this? In addition, the macro is extremely slow... Thanks for your help.



VBA Code:
Option Explicit

Sub ImportExcelfiles()
   Dim strPath As String
   Dim strFile As String
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wsTarget As Worksheet
  
   Dim rowCountSource As Long
   Dim colCountSource As Long
   Dim rowOutputTarget As Long
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
   '============================
   'EDIT THE PATH TO THE FOLDER
   '============================
   strPath = "C: \MyPath\"
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
 
  
   'set the target worksheet
   Set wsTarget = ThisWorkbook.Worksheets("Sheet1")
  
   'set the initial output row
   rowOutputTarget = 2
  
   'get the first file
   strFile = Dir(strPath & "*.xlsx*")
  
   'loop throught the excel files in the folder
   Do While strFile <> ""
      
      

      If Left(strFile, 19) = "NAV_PACK_L3264_2020" Then


         'open the workbook
         Set wbSource = Workbooks.Open(strPath & strFile)
         Set wsSource = wbSource.Worksheets("Exchange rates")
        
         'get the row and column counts
         With wsSource
            'row count based on column 1 = A
            rowCountSource = .Cells(.Rows.Count, 1).End(xlUp).Row
            
            'column count based on row 1
            colCountSource = .Cells(1, .Columns.Count).End(xlToLeft).Column
         End With
      
         'copy and paste from A2
         wsSource.Range("C2", "F10").Copy
         wsTarget.Range("A" & rowOutputTarget).PasteSpecial Paste:=xlPasteValues
      
         'update output row
         rowOutputTarget = rowOutputTarget + rowCountSource - 1
        
         'close the opened workbook
         wbSource.Close SaveChanges:=False
      End If
      'get the next file
      strFile = Dir()
   Loop
  
   wsTarget.Range("$A$1:$D$500").AutoFilter Field:=2, Criteria1:=Array( _
        "AUD", "CAD", "CHF", "EUR", "GBP", "JPY"), Operator:=xlFilterValues
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$O$52").AutoFilter Field:=2
  
   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
  
   MsgBox ("Done")
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 

Some videos you may like

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,698
Bi Bering,

Try this:

VBA Code:
Option Explicit
Sub ImportExcelfiles()

    Dim strPath As String
    Dim strFile As String
    Dim strExchRateDate As String
    Dim strFromDate As String, strToDate As String
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
  
    Dim rowCountSource As Long
    Dim colCountSource As Long
    Dim rowOutputTarget As Long
    
    Dim xlnCalcMethod As XlCalculation
  
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        xlnCalcMethod = .Calculation 'Grab current workbook calculation method to restore at end
        .Calculation = xlCalculationManual 'Set workbook calculation method to manual for faster processing
    End With
    
   '============================
   'EDIT THE PATH TO THE FOLDER
   '============================
    strPath = "C:\MyPath\"
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  
   'set the target worksheet
    Set wsTarget = ThisWorkbook.Worksheets("Sheet1")
  
   'set the initial output row
    rowOutputTarget = 2
  
   'get the first file
    strFile = Dir(strPath & "*.xlsx")
    
    'Set date range for which files to use.  These could also be two cells on a sheet.
    strFromDate = "31/12/2019"
    strDateTo = "31/03/2020"
  
   'loop throught the excel files in the folder
    Do While strFile <> ""

        'If Left(strFile, 19) = "NAV_PACK_L3264_2020" Then
        If InStr(strFile, "NAV_PACK_L3264") > 0 Then
        
            strExchRateDate = Mid(strFile, 16, 8)
            strExchRateDate = Right(strExchRateDate, 2) & "/" & Mid(strExchRateDate, 5, 2) & "/" & Left(strExchRateDate, 4)
            
            If DateValue(strExchRateDate) >= DateValue(strFromDate) And DateValue(strExchRateDate) <= DateValue(strDateTo) Then
                'open the workbook
                Set wbSource = Workbooks.Open(strPath & strFile)
                Set wsSource = wbSource.Worksheets("Exchange rates")
        
                'get the row and column counts
                With wsSource
                    'row count based on column 1 = A
                    rowCountSource = .Cells(.Rows.Count, 1).End(xlUp).Row
                    'column count based on row 1
                    colCountSource = .Cells(1, .Columns.Count).End(xlToLeft).Column
                End With
        
                'copy and paste from A2
                wsSource.Range("C2", "F10").Copy
                wsTarget.Range("A" & rowOutputTarget).PasteSpecial Paste:=xlPasteValues
        
                'update output row
                rowOutputTarget = rowOutputTarget + rowCountSource - 1
        
                'close the opened workbook
                wbSource.Close SaveChanges:=False
            End If
      End If
      
      'get the next file
      strFile = Dir()
      
    Loop
  
   wsTarget.Range("$A$1:$D$500").AutoFilter Field:=2, Criteria1:=Array( _
        "AUD", "CAD", "CHF", "EUR", "GBP", "JPY"), Operator:=xlFilterValues
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$O$52").AutoFilter Field:=2
  
   'tidy up
    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wsTarget = Nothing
  
    MsgBox ("Done")
  
    With Application
        .Calculation = xlnCalcMethod 'Set workbook calculation method to what it was at the start of the macro
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert
 
Solution

Bering

Board Regular
Joined
Aug 22, 2018
Messages
125
Office Version
  1. 2016
Platform
  1. Windows
Thank you very much, it works perfectly! (y)(y)(y)(y)


(I only had to fix the strToDate variable, as it is referred to as strDateTo in the code.)



Bi Bering,

Try this:

VBA Code:
Option Explicit
Sub ImportExcelfiles()

    Dim strPath As String
    Dim strFile As String
    Dim strExchRateDate As String
    Dim strFromDate As String, strToDate As String
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
 
    Dim rowCountSource As Long
    Dim colCountSource As Long
    Dim rowOutputTarget As Long
   
    Dim xlnCalcMethod As XlCalculation
 
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        xlnCalcMethod = .Calculation 'Grab current workbook calculation method to restore at end
        .Calculation = xlCalculationManual 'Set workbook calculation method to manual for faster processing
    End With
   
   '============================
   'EDIT THE PATH TO THE FOLDER
   '============================
    strPath = "C:\MyPath\"
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
 
   'set the target worksheet
    Set wsTarget = ThisWorkbook.Worksheets("Sheet1")
 
   'set the initial output row
    rowOutputTarget = 2
 
   'get the first file
    strFile = Dir(strPath & "*.xlsx")
   
    'Set date range for which files to use.  These could also be two cells on a sheet.
    strFromDate = "31/12/2019"
    strDateTo = "31/03/2020"
 
   'loop throught the excel files in the folder
    Do While strFile <> ""

        'If Left(strFile, 19) = "NAV_PACK_L3264_2020" Then
        If InStr(strFile, "NAV_PACK_L3264") > 0 Then
       
            strExchRateDate = Mid(strFile, 16, 8)
            strExchRateDate = Right(strExchRateDate, 2) & "/" & Mid(strExchRateDate, 5, 2) & "/" & Left(strExchRateDate, 4)
           
            If DateValue(strExchRateDate) >= DateValue(strFromDate) And DateValue(strExchRateDate) <= DateValue(strDateTo) Then
                'open the workbook
                Set wbSource = Workbooks.Open(strPath & strFile)
                Set wsSource = wbSource.Worksheets("Exchange rates")
       
                'get the row and column counts
                With wsSource
                    'row count based on column 1 = A
                    rowCountSource = .Cells(.Rows.Count, 1).End(xlUp).Row
                    'column count based on row 1
                    colCountSource = .Cells(1, .Columns.Count).End(xlToLeft).Column
                End With
       
                'copy and paste from A2
                wsSource.Range("C2", "F10").Copy
                wsTarget.Range("A" & rowOutputTarget).PasteSpecial Paste:=xlPasteValues
       
                'update output row
                rowOutputTarget = rowOutputTarget + rowCountSource - 1
       
                'close the opened workbook
                wbSource.Close SaveChanges:=False
            End If
      End If
     
      'get the next file
      strFile = Dir()
     
    Loop
 
   wsTarget.Range("$A$1:$D$500").AutoFilter Field:=2, Criteria1:=Array( _
        "AUD", "CAD", "CHF", "EUR", "GBP", "JPY"), Operator:=xlFilterValues
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$O$52").AutoFilter Field:=2
 
   'tidy up
    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wsTarget = Nothing
 
    MsgBox ("Done")
 
    With Application
        .Calculation = xlnCalcMethod 'Set workbook calculation method to what it was at the start of the macro
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,698
Thank you very much, it works perfectly!

Thanks for letting us know and you're welcome.

I only had to fix the strToDate variable, as it is referred to as strDateTo in the code.

Sorry about that :oops: I'm not sure why the macro didn't error our when I tested it as I use Option Explicit for that very reason :confused:

Robert
 

Bering

Board Regular
Joined
Aug 22, 2018
Messages
125
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

No issues at all! Thank you very much Robert.

Thanks for letting us know and you're welcome.



Sorry about that :oops: I'm not sure why the macro didn't error our when I tested it as I use Option Explicit for that very reason :confused:

Robert
 

rjmdc

Active Member
Joined
Apr 29, 2020
Messages
364
Office Version
  1. 365
Platform
  1. Windows
hi
i want to use this code and tweak for my purposes.
please assist
i want to loop through all workbooks (1 page books, each named page 1) in folder
extract row 2 (a merged row A2:N2)
copy to a different worksheet named CIN
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,698
Hi rjmdc,

It's probably best to start a new thread with a link back to this one if you think it will help.

Thanks,

Robert
 

Watch MrExcel Video

Forum statistics

Threads
1,119,088
Messages
5,576,040
Members
412,694
Latest member
Deaf1Too
Top