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

[MoonLove]

Dear friends,

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 another one workbook called consolidated workbook with the same worksheets names(products, channels, and sales) like those of the four source workbooks.
- I want a 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.

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

 

[Alex Blakenburg]

I was wondering what time zone you were in . You are welcome. Glad I could help.

 

[MoonLove]

East Africa Time Zone.

 

[MoonLove]

Dear Alex,

Thanks to you, currently the macro works perfectly fine for copying data of today's date from source to destinations.

Have got one issue, how can I accommodate a scenario whereby the macro was not able to be run on the same day? How can I retrieve yesterdays data that were not copied to master workbook - worksheet.

How can this scenario be accommodated?

 

[Alex Blakenburg]

And that is why I am not a big fan of how people use Today() in formulas or Date in VBA.

I have catered for that by only looking up the Date (today's date) once at the beginning of the code.
So you can either manually code in a date there in the code or what I would suggest is use a range on the spreadsheet from which you are initiating the code, (I assume you are using a button)
Note: You could still use =today() on the spreadsheet but it gives you an option of changing that on the spreadsheet rather than in VBA should you need to change it.


To manually change the code:

    ' Commment out one of the following
    'lngDate = CLng(Date)
    lngDate = CLng(DateSerial(2023, 1, 25))     ' Format is (yyyy, m, d)

To Change it to use what you have in the spreadsheet use something like this.
(I have used B1 on the Active sheet)

    'replace this:-
    'lngDate = CLng(Date)

    ' with this
    ' Read date from spreadsheet
    Dim homeSht As Worksheet
    Set homeSht = thisworkbbok.ActiveSheet           ' Assuming you are using a button
    lngDate = homeSht.Range("B1").Value2            ' <-- Change to cell or Range Name containing date required.  *** Make sure you use Value2 ***

 

[MoonLove]

Dear Alex,

I opted to use the first option which is manually changing the code and it has worked.

I couldnot utilise the second option since Iam not using a button click. I wanted to understand something, is there any other way to accomodate such kind of a scenario without needed to go and manually amend the code.

    Sub Copy_From_All_Workbooks()
    Dim wb As String, i As Long, sh As Worksheet
    Dim srcRng As Range, srcArr As Variant
    Dim destRng As Range, destArr()
    Dim isrc As Long, idest As Long, icol As Long
    Dim lngDate As Long

    Application.ScreenUpdating = False
    wb = Dir(ThisWorkbook.Path & "\*")
    
    ' Commment out one of the following
    'lngDate = CLng(Date)
    lngDate = CLng(DateSerial(2023, 1, 25))     ' Format is (yyyy, m, d)
    Do Until wb = ""
        If wb <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & wb
                For Each sh In Workbooks(wb).Worksheets
                        With sh.UsedRange
                            Set srcRng = .Offset(1).Resize(.Rows.Count - 1)           '<---- Assumes 1 header row
                            srcArr = srcRng.Value2
                        End With

                        ReDim destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
                        idest = 0
                        For isrc = 1 To UBound(srcArr)
                            If CLng(srcArr(isrc, 1)) = lngDate Then
                                idest = idest + 1
                                For icol = 1 To UBound(srcArr, 2)
                                    destArr(idest, icol) = srcArr(isrc, icol)
                                Next icol
                            End If
                        Next isrc
                         ' Wrap the output statements in an If statement like this
                        If idest <> 0 Then
                            Set destRng = ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1)
                            Set destRng = destRng.Resize(idest, UBound(destArr, 2))
                            destRng = destArr
                        End If
                
                Next sh
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[MoonLove]

Meaning the code should be flexible in such a way, it just copies anything that was not copied from the last copy event. Thank you.

 

[Alex Blakenburg]

You could
1) Store the date you last used in the spreadsheet that contains the code either in a cell or a named range
2) Check each sheet for the Max value in the sheet and increase the date by 1 then use that as your date.
That would take a bit of rearranging of the existing code and it would run a little slower.

 

[MoonLove]

Dear Alex,

Where should I amend on the below code?

    Sub Copy_From_All_Workbooks()
    Dim wb As String, i As Long, sh As Worksheet
    Dim srcRng As Range, srcArr As Variant
    Dim destRng As Range, destArr()
    Dim isrc As Long, idest As Long, icol As Long
    Dim lngDate As Long

    Application.ScreenUpdating = False
    wb = Dir(ThisWorkbook.Path & "\*")
    
    ' Commment out one of the following
    'lngDate = CLng(Date)
    lngDate = CLng(DateSerial(2023, 1, 25))     ' Format is (yyyy, m, d)
    Do Until wb = ""
        If wb <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & wb
                For Each sh In Workbooks(wb).Worksheets
                        With sh.UsedRange
                            Set srcRng = .Offset(1).Resize(.Rows.Count - 1)           '<---- Assumes 1 header row
                            srcArr = srcRng.Value2
                        End With

                        ReDim destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
                        idest = 0
                        For isrc = 1 To UBound(srcArr)
                            If CLng(srcArr(isrc, 1)) = lngDate Then
                                idest = idest + 1
                                For icol = 1 To UBound(srcArr, 2)
                                    destArr(idest, icol) = srcArr(isrc, icol)
                                Next icol
                            End If
                        Next isrc
                         ' Wrap the output statements in an If statement like this
                        If idest <> 0 Then
                            Set destRng = ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1)
                            Set destRng = destRng.Resize(idest, UBound(destArr, 2))
                            destRng = destArr
                        End If
                
                Next sh
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

Ok
Replace this:

    ' Commment out one of the following
    'lngDate = CLng(Date)
    lngDate = CLng(DateSerial(2023, 1, 25))     ' Format is (yyyy, m, d)

With this:
(I have hard coded 3 sheet names to look at to get the maximum date)

    Dim arrshtnames As Variant
    Dim templngDate As Long
    arrshtnames = Array("Products", "Sales", "Channels")
   
    For i = 0 To UBound(arrshtnames)
        Set sh = ThisWorkbook.Worksheets(arrshtnames(i))
        templngDate = Application.WorksheetFunction.Max(sh.Columns("A").Value2)
        If lngDate < templngDate Then lngDate = templngDate
    Next i
   
    If lngDate = 0 Then
        lngDate = CLng(Date)
    Else
        lngDate = lngDate + 1
    End If

 

[MoonLove]

Dear Alex,

Thank you so much.

I run the code but what I noticed is that, if the report has not been run yesterday, when I run it today evening at first it picks only yesterday's data and if you want to pull data as of today's date you are supposed to run the code again.

What I thought is that the code would go and copy all data which have not been copied from the last copy event then let's say if I forgot to run the report yesterday, and I run it today evening, the code will copy all data from yesterday to today at once.

    Sub Copy_From_All_Workbooks()
    Dim wb As String, i As Long, sh As Worksheet
    Dim srcRng As Range, srcArr As Variant
    Dim destRng As Range, destArr()
    Dim isrc As Long, idest As Long, icol As Long
    Dim lngDate As Long
    Dim arrshtnames As Variant
    Dim templngDate As Long
    arrshtnames = Array("Products", "Sales", "Channels")

    Application.ScreenUpdating = False
    wb = Dir(ThisWorkbook.Path & "\*")
  
    For i = 0 To UBound(arrshtnames)
        Set sh = ThisWorkbook.Worksheets(arrshtnames(i))
        templngDate = Application.WorksheetFunction.Max(sh.Columns("A").Value2)
        If lngDate < templngDate Then lngDate = templngDate
    Next i
 
    If lngDate = 0 Then
        lngDate = CLng(Date)
    Else
        lngDate = lngDate + 1
    End If
  
    Do Until wb = ""
        If wb <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & wb
                For Each sh In Workbooks(wb).Worksheets
                        With sh.UsedRange
                            Set srcRng = .Offset(1).Resize(.Rows.Count - 1)           '<---- Assumes 1 header row
                            srcArr = srcRng.Value2
                        End With

                        ReDim destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
                        idest = 0
                        For isrc = 1 To UBound(srcArr)
                            If CLng(srcArr(isrc, 1)) = lngDate Then
                                idest = idest + 1
                                For icol = 1 To UBound(srcArr, 2)
                                    destArr(idest, icol) = srcArr(isrc, icol)
                                Next icol
                            End If
                        Next isrc
                         ' Wrap the output statements in an If statement like this
                        If idest <> 0 Then
                            Set destRng = ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1)
                            Set destRng = destRng.Resize(idest, UBound(destArr, 2))
                            destRng = destArr
                        End If
              
                Next sh
            Workbooks(wb).Close False
        End If
        wb = Dir
    Loop
    Application.ScreenUpdating = True
End Sub