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

B

Bering

Board Regular
Joined
Aug 22, 2018
Messages
186
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
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
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
 
Upvote 0
Solution
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.)



Trebor76 said:
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
Click to expand...
 
Upvote 0
Thank you very much, it works perfectly!
Click to expand...

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.
Click to expand...

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
 
Upvote 0
No issues at all! Thank you very much Robert.

Trebor76 said:
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
Click to expand...
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Loop through Rows
Replies
4
Views
295
rollingzep
R
F
  • Question Question
Macro that copies and pastes from each file into formatted master sheet with merged cells
Replies
1
Views
933
OaklandJim
O
C
  • Question Question
Need to search in all files within all folders also.
Replies
5
Views
441
Domenic
D
L
  • Question Question
VBA - Search all folders for datal/text
Replies
4
Views
668
MikeVol
MikeVol
M
  • Question Question
Copy File Names to Destination File
Replies
2
Views
304
metalscuba
M

Forum statistics

Threads
1,223,227
Messages
6,170,853
Members
452,361
Latest member
d3ad3y3

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