VBA Code to copy data from four source workbooks to master workbook based on last row that was not previously copied

Question

I have a challenge on achieving the below project, kindly please assist:

• I have four source workbooks with names(GK,SK,RJ and TB).

• Each workbook(GK,SK,RJ and TB) have three worksheets with the same names(products, channels, and sales).

• I have destination workbook called consolidated workbook with the same worksheets names(products, channels, and sales) like those of the four source workbooks.

• All workbooks(source + destinations) are in the same folder.

• Iam requesting VBA code that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.

• Currently I have the below code but whenever I ran it copies everything from worksheets on the source workbooks and paste to worksheets in consolidated workbook which result to duplicated data.

• All the source workbook have worksheets with the "DATE" as a first column in each worksheet table column.

• Destination workbook also have the same worksheet names and the same columns structure on each worksheet are the same as of those source worksheet.

• Kindly advise what should I amend so that the code will that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.

Sub Copy_From_All_Workbooks()
    Dim wb As String, i As Long, sh As Worksheet
    Application.ScreenUpdating = False
    wb = Dir(ThisWorkbook.Path & "\*")
    Do Until wb = ""
        If wb <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & wb
                For Each sh In Workbooks(wb).Worksheets
                        sh.UsedRange.Offset(1).Copy   '<---- Assumes 1 header row
                            ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                Next sh
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

• Kindly please see the amended code:

    Sub Copy_From_All_Workbooks()
    Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, 
    start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As 
    Range
    Application.ScreenUpdating = False
    wb = Dir(ThisWorkbook.Path & "\*")
    Do Until wb = ""
    If wb <> ThisWorkbook.Name Then
         Workbooks.Open ThisWorkbook.Path & "\" & wb
            For Each sh In Workbooks(wb).Worksheets
            On Error Resume Next
            sh.UsedRange.Offset(1).Copy   '<---- Assumes 1 header row
            Set fndRng = sh.Range("A:A").Find(date_to_find,LookIn:=xlValues, 
        searchdirection:=xlPrevious)
                
                If Not fndRng Is Nothing Then
                    start_of_copy_row = fndRng.Row + 1
                   Else
                   start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
                 End If

                   end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

                   Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
                        
                        latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
                
                       ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        
                   On Error GoTo 0
                   
                   Application.CutCopyMode = False
                   
                Next sh
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
   End Sub

Kindly please see how consolidated workbook appear(the sheet names and column format are exactly the same as of the source workbooks.)

CONSOLIDATED WORKBOOK

Answer 1

The following line can be used to find the latest date loaded on your consolidated sheet:

latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))

The following lines can be used on a worksheet (sh) to create a range (for copying) that starts after the latest_date_loaded down to the bottom of the table. You'll therefore need to ensure this is in date order.

Dim fndRng As Range, start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As Range

date_to_find = latest_date_loaded


Set fndRng = sh.Range("A:A").Find(date_to_find, LookIn:=xlValues, searchdirection:=xlPrevious)

If Not fndRng Is Nothing Then
    start_of_copy_row = fndRng.Row + 1
Else
    start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If

end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)

EDIT

Here is a rework of your code, using some of the lines/ideas I've mentioned above.

Sub Copy_From_All_Workbooks()
    
    'declarations 
    Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, _
    start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As _
    Range, latest_date_loaded As Date, consolidated_wb As Workbook
    
    'turn off screen updating for user experience
    'Application.ScreenUpdating = False
    
    'set a reference to the consolidated workbook
    Set consolidated_wb = ThisWorkbook
    
    'read parent folder of consolidated workbook
    wb = Dir(consolidated_wb.Path & "\*")
    
    'perform this loop until no more files
    Do Until wb = ""
    
        'make sure it doesn't try to open consolidated workbook (again)
        If wb <> consolidated_wb.Name Then
        
            'open found source workbook
            Workbooks.Open consolidated_wb.Path & "\" & wb
            
            'cycle through each sheet (sh)
            For Each sh In Workbooks(wb).Worksheets
                
                'on that sheet, find the latest date already existing
                latest_date_loaded = Application.WorksheetFunction.Max(consolidated_wb.Sheets(sh.Name).Range("A:A"))

                'find the last occurence of that date in column A
                Set fndRng = sh.Range("A:A").Find(latest_date_loaded, LookIn:=xlValues, _
                searchdirection:=xlPrevious)
                
                'if you find that date already then..
                If Not fndRng Is Nothing Then
                    'set the top row to where you found it, plus one
                    start_of_copy_row = fndRng.Row + 1
                Else
                    'otherwise, it's a new sheet, start on row two
                    start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
                End If
                
                'find the end of the table, using column A's contents
                end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
                
                'make sure there's something to copy
                If end_of_copy_row >= start_of_copy_row Then
                
                    'create a reference to the block of cells to copy
                    Set range_to_copy = sh.Range(start_of_copy_row & ":" & end_of_copy_row)
                    
                    'copy that range
                    range_to_copy.Copy
                    
                    'paste them, values only
                    consolidated_wb.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    
                    'clear copy markings from screen
                    Application.CutCopyMode = False
                Else
                
                    'otherwise, do nothing here
                    
                End If
                
            Next sh
            
            'close the source workbook
            Workbooks(wb).Close False
        End If
        
        'get next potential filename
        wb = Dir
        
    Loop

    'turn back on screen updating
    Application.ScreenUpdating = True
    
End Sub