Macro to compare columns and copy rows.

My last post just timed out so I lost all my notes... Trying again...

I'm trying to create a macro to scrub new data and update my records for a rolling 30 day dashboard and other charts that feed off the main dataset...

Example file attached. I need to scan the 'New' worksheet tab, Column A [Record] against the 'Old' worksheet tab, also Column A [Record]. If a match is found then copy the row of "New" data over the row of "Old" data. If a match is not found append the "New" row to the end of the "Old" sheet / table.

I also need code to then delete rows from the 'Old' sheet that are 30 days or older than today.

Please let me know if there is any additional information I can provide, sorry my last post timed out and I lost all the extras I had included.

Thank you,
Jason.

Option Explicit

Sub DoThings()

    Dim wsN As Worksheet, wsO As Worksheet
    Dim lrow As Integer, nrow As Integer, i As Integer
    Dim str As String, str2 As String
    Dim fndrng As Range
    
    Set wsN = ThisWorkbook.Sheets("NEW")
    Set wsO = ThisWorkbook.Sheets("OLD")
    
    lrow = wsN.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
    nrow = wsO.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row + 1
    
    i = 2
    
    Do While i <= lrow
        Set fndrng = wsO.Range("A:A").Find(what:=wsN.Cells(i, 1))
        str = "A" & i & ":F" & i
        
        If fndrng Is Nothing Then
            str2 = "A" & nrow
            nrow = nrow + 1
            
        Else
            str2 = "A" & fndrng.Row
            
        End If
            
        wsN.Range(str).Copy
        wsO.Range(str2).PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
        
        'Enable the two rows below if you want to delete the row from New after it has been
        'processed. Remove the ' to un-comment. Also, if you enable them, delete the row below
        'them.
        
'        wsN.Rows(i).Delete
'        lrow = lrow - 1

        i = i + 1   'Delete this if you enable the two commands above
        
    Loop

End Sub

And here is the code to remove stuff over 30 days. You can add the command "Call RemoveOldStuff" to the end of the previous script to flow into this one.

Sub RemoveOldStuff()

    Dim ws As Worksheet
    Dim ddate As Date
    Dim i As Integer, lrow As Integer
    
    Set ws = ThisWorkbook.Sheets("OLD")
    ddate = Date - 30
    lrow = ws.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
    i = 2
    
    Do While i <= lrow
        If ws.Cells(i, 4) < ddate Then
            ws.Rows(i).Delete
            i = i - 1
            lrow = lrow - 1
            
        End If
        
        i = i + 1
        
    Loop

End Sub

Can also try adding the below along with screenupdating.

Application.Calculation = xlCalculationManual     'then xlCalculationAutomatic   at the end

This is an alternate method of moving the data over:

Sub DoThings()

    Dim wsN As Worksheet, wsO As Worksheet
    Dim lrow As Integer, nrow As Integer, i As Integer, j As Integer, rw As Integer
    Dim fndrng As Range
    
    Set wsN = ThisWorkbook.Sheets("NEW")
    Set wsO = ThisWorkbook.Sheets("OLD")
    
    lrow = wsN.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
    nrow = wsO.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row + 1
    
    i = 2
    
    Do While i <= lrow
        Set fndrng = wsO.Range("A:A").Find(what:=wsN.Cells(i, 1))
        
        If fndrng Is Nothing Then
            rw = nrow
            nrow = nrow + 1
            
        Else
            rw = fndrng.Row
            
        End If
        
        For j = 1 To 6
            wsO.Cells(rw, j) = wsN.Cells(i, j)
            
        Next j
        
        'Enable the two rows below if you want to delete the row from New after it has been
        'processed. Remove the ' to un-comment. Also, if you enable them, delete the row below
        'them.
        
'        wsN.Rows(i).Delete
'        lrow = lrow - 1

        i = i + 1   'Delete this if you enable the two commands above
        
    Loop

End Sub

Ok, your second method worked in a snap, less than 5 minutes for the remainder of data and it was complete. I'll run a few more tests before I can use it in our day-to-day but I can't thank you enough.

If you have a moment can you explain the major difference between your first method to the second as to why it would be so much faster?

The first method used copy and paste. The second method... hmm... hard to explain. It just sets one cell equal to the other so I guess maybe it is using internal memory? Not quite sure how to explain that better.

It's all good, it works and works well. So thankful for your help, have a great day and end of year!

With it running that long... do you have the two commands I initially commented out enabled or disabled? If it is deleting each row, we can change that up too which can make it run faster.

I'm still running tests. I've converted the variables and some of the structure to fit with the dataset in my report. I also noticed it was only copying 6 columns of data, my actual dataset has 36 which I think was your line:

For j = 1 to 6

So I changed it to:

For j = 1 to 36

Now I get an error when the 'Next J' loop completes

Sub DataScrub()

    Dim wsNew As Worksheet, wsINC As Worksheet
    Dim lrow As Integer, nrow As Integer, i As Integer, j As Integer, rw As Integer
    Dim fndrng As Range
    Set wsNew = ThisWorkbook.Sheets("Page 1")
    Set wsINC = ThisWorkbook.Sheets("INCDATA")
    lrow = wsNew.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
    nrow = wsINC.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row + 1
    
    i = 2
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Do While i <= lrow
        Set fndrng = wsINC.Range("A:A").Find(what:=wsNew.Cells(i, 1))
        If fndrng Is Nothing Then
            rw = nrow
            nrow = nrow + 1
        Else
            rw = fndrng.Row
        End If
        For j = 1 To 36
            wsINCDATA.Cells(rw, j) = wsNew.Cells(i, j)
        Next j
        wsNew.Rows(i).Delete
        lrow = lrow - 1
    Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

You changed the name of the variable from wsINC to wsINCDATA in the line with:

wsINCDATA.Cells(rw, j) = wsNew.Cells(i, j)

Yes, my apologies. I'm trying to juggle 10 things at work today while working on this code as well and pasted a previous iteration from my notes..


Here is the direct copy paste from Excel's vba editor:

Sub DataScrub()

    Dim wsNew As Worksheet, wsINC As Worksheet
    Dim lrow As Integer, nrow As Integer, i As Integer, j As Integer, rw As Integer
    Dim fndrng As Range
    Set wsNew = ThisWorkbook.Sheets("Page 1")
    Set wsINC = ThisWorkbook.Sheets("INCDATA")
    lrow = wsNew.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
    nrow = wsINC.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row + 1
    
    i = 2
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Do While i <= lrow
        Set fndrng = wsINC.Range("A:A").Find(what:=wsNew.Cells(i, 1))
        If fndrng Is Nothing Then
            rw = nrow
            nrow = nrow + 1
        Else
            rw = fndrng.Row
        End If
        For j = 1 To 36
            wsINC.Cells(rw, j) = wsNew.Cells(i, j)
        Next j
        wsNew.Rows(i).Delete
        lrow = lrow - 1
    Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

With the above it's running through about 1100-1400 rows (of the 3400) then throwing an error in the j loop. I'm going to clear everything and try again with some new test data.

What are the values in rw, i, and j when it bugs? To find that, in the immediate window (CTRL+G if not visible) type ?rw,i,j and press enter.

lrow 3143
nrow 2496
rw 1436
i 2
j 29

the INCDATA tab has 2495 rows (first is a header)
the 'Page 1' tab has 3685 (also has a header)

I've reset the sheet and imported the test data several times now and it's stopping in the same place with the same values for the variables you requested.

And how many rows are on wsINC?

That's very random. When it stops, what is the value in AC2? If you cannot post it for privacy, take a look at that cell. It's the one that Excel is upset over.

Ok, on the INCDATA sheet Row 1436, Column AC contains a ton of information. One of my techs decided to write a book ...

This could be part of the problem.

That is my thought. The value must be too long in length.

Can either skip that column entirely, something like

If j <> 29 then

Can also check the length. Not sure what the maximum is, but you can do something like

If Len(wsNew.Cells(i, j)) < 255 then   'Again, no clue what the maximum is.

I will rework the report to remove column AC from being extracted in the first place. Thanks again for your help!!

Don't forget to adjust For j = 1 to 36 as necessary.