Copy worksheet from multiple workbooks and append to one worksheet

[Pumper]

Hi All,

Have watched multiple videos and looked through examples but can't seem to find what I am after...

I would like to look through a folder and if the file contains todays date anywhere in the name of the file then copy to sheet 1 of the current workbook (not in the same directory). These source workbooks only ever contain one worksheet but the name changes constantly.

If there are multiple files containing todays date I would like them to append to the same worksheet 1.

Sample folder where source files are G:\Home\Performance
Directory of workbook where the paste/append takes place C:\Users\me
Sample file name example HPhde_20220321_da.csv (date will always start and end with an underscore and will always be .csv).

Hopefully that is clear...

Any help would be much appreciated.

 

[John_w]

Try this macro.

Public Sub Copy_Sheet_From_CSV_Files()

    Dim matchFiles As String
    Dim folderPath As String, fileName As String
    Dim copyFromWorkbook As Workbook
    Dim copyToRange As Range

    matchFiles = "G:\Home\Performance\*_????????_*.csv"
    
    With ActiveWorkbook.Worksheets(1)
        Set copyToRange = .Cells(.UsedRange.Row, "A")
        If copyToRange.Row > 1 Then Set copyToRange = copyToRange.Offset(1)
    End With
    
    Application.ScreenUpdating = False
    
    folderPath = Left(matchFiles, InStrRev(matchFiles, "\"))
    fileName = Dir(matchFiles)
    While fileName <> vbNullString
        If InStr(1, fileName, "_" & Format(Date, "YYYYMMDD") & "_") Then
            Set copyFromWorkbook = Workbooks.Open(folderPath & fileName)
            copyFromWorkbook.Worksheets(1).UsedRange.Copy copyToRange
            copyFromWorkbook.Close SaveChanges:=False
            Set copyToRange = copyToRange.Worksheet.Cells(copyToRange.Worksheet.UsedRange.Rows.Count, "A").Offset(1)
            DoEvents
        End If
        fileName = Dir
    Wend
        
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub

 

[Pumper]

Try this macro.

Public Sub Copy_Sheet_From_CSV_Files()

    Dim matchFiles As String
    Dim folderPath As String, fileName As String
    Dim copyFromWorkbook As Workbook
    Dim copyToRange As Range

    matchFiles = "G:\Home\Performance\*_????????_*.csv"
   
    With ActiveWorkbook.Worksheets(1)
        Set copyToRange = .Cells(.UsedRange.Row, "A")
        If copyToRange.Row > 1 Then Set copyToRange = copyToRange.Offset(1)
    End With
   
    Application.ScreenUpdating = False
   
    folderPath = Left(matchFiles, InStrRev(matchFiles, "\"))
    fileName = Dir(matchFiles)
    While fileName <> vbNullString
        If InStr(1, fileName, "_" & Format(Date, "YYYYMMDD") & "_") Then
            Set copyFromWorkbook = Workbooks.Open(folderPath & fileName)
            copyFromWorkbook.Worksheets(1).UsedRange.Copy copyToRange
            copyFromWorkbook.Close SaveChanges:=False
            Set copyToRange = copyToRange.Worksheet.Cells(copyToRange.Worksheet.UsedRange.Rows.Count, "A").Offset(1)
            DoEvents
        End If
        fileName = Dir
    Wend
       
    Application.ScreenUpdating = True
   
    MsgBox "Done"
   
End Sub

Thanks so much for your time John_w!

The only thing that needed changing was

From:
If InStr(1, fileName, "_" & Format(Date, "YYYYMMDD") & "_") Then
To:
If InStr(1, fileName, "_" & 20220318 & "_") Then

Ideally that date would be the previous weekday to day (Today-1 Weekday) each time (will see if I can get it to reference a cell within the sheet that has the date in it)

Thanks again for taking the time to look at this much appreciated.

 

[John_w]

For the previous weekday:

        If InStr(1, fileName, "_" & Format(Application.WorksheetFunction.WorkDay(Date, -1), "YYYYMMDD") & "_") Then

 

[Pumper]

For the previous weekday:

        If InStr(1, fileName, "_" & Format(Application.WorksheetFunction.WorkDay(Date, -1), "YYYYMMDD") & "_") Then

Brilliant, worked a treat!
This has helped automate some really boring processes so thank you very much!

People such as yourself make this website second to none...