Append data to master file

[jamescooper]

So the code below combines all files in the directory above into a single file.

I'd like now to be able to append the master file ("All data.xlsm") each time so that it runs through all the files from the last date in Column A + 1.

So in the above it would be 08/05/2024 and files with a greater date if the last date was 07/05/2024 as shown above.

Any code appreciated.

Many thanks.

Sub ImportFiles()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
Debug.Print DestSheet.Name
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
  
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
Lr2 = xWS.Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
If Lr = 1 Then
Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A" & Lr + 1)
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[jamescooper]

Can anyone help, do you need more information?

 

[Alex Blakenburg]

Your file names are very clean which helps, see if these changes do what you are after:

Sub ImportFiles()
    Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
    Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
    Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
    Dim FolderPath As String, fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
    
    Dim maxDate As Date, strFNameDate As String
    
    On Error Resume Next
    Set xTWB = ThisWorkbook
    Set DestSheet = xTWB.ActiveSheet
    
    With DestSheet
        Lr = .Range("A" & Rows.Count).End(xlUp).Row
        maxDate = WorksheetFunction.Max(.Range("A2:A" & Lr))
    End With
    
    Debug.Print DestSheet.Name
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
      With fldr
          .Title = "Select a Folder"
          .AllowMultiSelect = False
          .InitialFileName = Application.DefaultFilePath
          If .Show <> -1 Then GoTo NextCode
          sItem = .SelectedItems(1)
      End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
      
    FileName = Dir(FolderPath & "*.xls*")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Do While FileName <> ""
        strFNameDate = Left(FileName, 10)
        If IsDate(strFNameDate) Then
            If CDate(strFNameDate) > maxDate Then
                Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
                xStrAWBName = ActiveWorkbook.Name
                Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
                xStrName = Sh1.Name
                For Each xWS In ActiveWorkbook.Sheets
                    If xWS.Name = xStrName Then
                        Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
                        Lr2 = xWS.Range("A" & Rows.Count).End(xlUp).Row
                        Lc = Cells(1, Columns.Count).End(xlToLeft).Column
                        If Lr = 1 Then
                            Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A1")
                        Else
                            Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A" & Lr + 1)
                        End If
                    End If
                Next xWS
                Workbooks(xStrAWBName).Close
            End If
        End If
        FileName = Dir()
    Loop
    xTWB.Save
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[jamescooper]

This actually works really well thank you. The only bit which isn't quite calculating correctly is this line.

maxDate = WorksheetFunction.Max(.Range("A2:A" & Lr))

It correctly identifies the row number of the last date but in the file it is 11/08/2024 and in the code it is identifying it as 07/08/2024.

Any way to modify so it picks up the correct date?

Many thanks.

 

[Alex Blakenburg]

Can you try using the max function in the actual spreadsheet and see what its doing ?
If its not working can you type in =isnumber( and point it at the cell its not picking up ?

 

[jamescooper]

I've found a workaround that works.

Thank you for your help, really useful.

 

[Alex Blakenburg]

You're welcome. If you want to post what you ended up doing you can mark it as the solution and it may help others.