Comapring two excel worksheets and adding or deleting rows as needed

Good Afternoon,

I am new to VBA coding and need help with excel VBA.

I have one work book with two worksheets, one is a current worksheet (S1) the other is an update version of the first(S2). All columns are the same and each will contain approximately 20,000 rows of data in.

1. I want to compare each cell in column A of S2 to all of column A in S1
a. If cell from S2 is equal to any cell in column A of S1 then do nothing
b. If cell from S2 is not equal to any cell in column A of S1 then add the corresponding row data to S1

2. Compare each cell in cloumn A of S1 to each cell in column A of S2
a. If cell from S1 is equal to any cell in column A of S2 then do nothing
b. If cell from column A of S1 is not equal to any cell in column A of S2 then do:
1. Create new worksheet (S3) and add corresponding row of data to new row in S3
2. Delete corresponding row of data from S1

If you need a sample of the workbook I can sanitize and supply, but preferable on to give out.

Hi dmreno

Welcome to the Forum!

Try this code. The code assumes you have a header row in Row 1 of each worksheet. Let me know of issues

Option Explicit
Sub test()
    Dim lr1 As Long
    Dim lr2 As Long
    Dim lr3 As Long
    Dim nr1 As Long
    Dim nr3 As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cel1 As Range
    Dim cel2 As Range
    Dim FindString As String

    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Set ws2 = ActiveWorkbook.Sheets("Sheet2")
    Set ws3 = ActiveWorkbook.Sheets("Sheet3")

    lr1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lr2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
    nr1 = lr1 + 1
    Set rng2 = ws2.Range("A2:A" & lr2)

    For Each cel2 In rng2
        FindString = cel2.Value
        If Trim(FindString) <> "" Then
            With ws1.Range("A2:A" & lr1)
                Set rng1 = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If rng1 Is Nothing Then
                    cel2.EntireRow.Copy
                    ws1.Range("A" & nr1).PasteSpecial
                    nr1 = nr1 + 1
                    Application.CutCopyMode = False
                End If
            End With
        End If
    Next cel2

    lr1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lr3 = ws3.Range("A" & Rows.Count).End(xlUp).Row
    nr3 = lr3 + 1
    Set rng1 = ws1.Range("A2:A" & lr1)

    For Each cel1 In rng1
        FindString = cel1.Value
        If Trim(FindString) <> "" Then
            With ws2.Range("A2:A" & lr2)
                Set rng2 = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If rng2 Is Nothing Then
                    cel1.EntireRow.Copy
                    ws3.Range("A" & nr3).PasteSpecial
                    nr3 = nr3 + 1
                    cel1.EntireRow.ClearContents
                    Application.CutCopyMode = False
                End If
            End With
        End If
    Next cel1
    With ws1
        lr1 = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1:A" & lr1).AutoFilter Field:=1, Criteria1:="="
        .UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilterMode = False
    End With
End Sub

Hi dmreno

Actually the code is significantly less complex with far fewer IO's. I'm assuming you've run the procedure on a COPY of the real file???
Assuming you did, kill the procedure (hold down the escape key...it may take a bit...make a note of the line of code where the procedure break point is) and let me know that line.
Assuming you didn't, I have to assume you have a BACKUP???

Let me play with it for a bit...I can look at eliminating the Copy/Paste stuff...that may speed it up.

Hi David
You're welcome...glad I could help.

Hi David

I should of asked and didn't...which file ALWAYS has the fewer records...OldMel or NewMel?

Hi dmreno

Yes I received your PM. Been on the road for the last several days with Family responsibilities...haven't paid too much attention to the Forum. I'll look at this probably tomorrow.

Hi David
See if this code works any better

Option Explicit
Sub test()
    Dim lr1 As Long
    Dim lr2 As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cel2 As Range
    Dim FindString As String

    Application.ScreenUpdating = False
    Set ws1 = Sheet1    'NewMel
    Set ws2 = Sheet2    'OldMel

    lr1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lr2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
    Set rng2 = ws2.Range("A2:A" & lr2)

    'With each value in OldMel Column A, find it in
    'NewMel Column A;  if found, replace NewMel row with OldMel row;
    'if not found do nothing

    For Each cel2 In rng2    'OldMel
        FindString = cel2.Value
        If Trim(FindString) <> "" Then
            With ws1.Range("A2:A" & lr1)
                Set rng1 = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If Not rng1 Is Nothing Then
'                                        Application.Goto rng1, True
'                    ws2.Range("A" & cel2.Row).EntireRow.Copy
'                    ws1.Range("A" & rng1.Row).PasteSpecial
                    ws1.Range("A" & rng1.Row).Resize(1, 21).Value = ws2.Range("A" & cel2.Row).Resize(1, 21).Value
'                    Application.CutCopyMode = False
                End If
            End With
        End If
    Next cel2
    Application.ScreenUpdating = True
End Sub

Hi dmreno
Dummy up a file that represents what you're working with. Please show examples of S1 and S2. Include S3 that demonstrates what you wish to see in S3. If you choose not to do so, I'll need to do so and I'd prefer not to guess.

Hi David

Then try this code...let me know what works...what doesn't

Option Explicit
Sub test()
    Dim lr1 As Long
    Dim lr2 As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cel2 As Range
    Dim FindString As String
    Dim xlCalc As XlCalculation
    
    On Error GoTo ExitPoint
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set ws1 = Sheet1    'NewMel
    Set ws2 = Sheet2    'OldMel

    lr1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lr2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
    Set rng2 = ws2.Range("A2:A" & lr2)

    'With each value in OldMel Column A, find it in
    'NewMel Column A;  if found, replace NewMel row with OldMel row;
    'if not found do nothing

    For Each cel2 In rng2    'OldMel
        FindString = cel2.Value
        If Trim(FindString) <> "" Then
            With ws1.Range("A2:A" & lr1)
                Set rng1 = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If Not rng1 Is Nothing Then
                    
                    ws1.Range("A" & rng1.Row).Resize(1, 21).Value = ws2.Range("A" & cel2.Row).Resize(1, 21).Value
                End If
            End With
        End If
    Next cel2
ExitPoint:
    With Application
        .Calculation = xlCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Hi David...the two are the same code and do the same things the same way. The second version turns off calculation so I would expect it to be at least marginally faster.

Hi dmreno
I've gotta admit, I'm a bit confused about what you're after. The code in the attached does this:

First
With each value in Current Sheet Column A, find it in
Update Sheet Column A; if found, copy Update Sheet Columns
H, I and J values to Current Sheet Columns H, I and J

Second
With each value in Update Sheet Column A, find it in
Current Sheet Column A; if not found, copy Update Sheet entire row
to the next row on Current Sheet

The results I get look nothing like the results you get. Explain a bit further and perhaps we can get on the same page.

You're welcome.

Hi dmreno

This code is in the attached and does this:
With each value in OldMel Column A, find it in NewMel Column A; if found, replace NewMel row with OldMel row; if not found do nothing.

Let me know of issues.

Option Explicit
Sub test()
    Dim lr1 As Long
    Dim lr2 As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cel2 As Range
    Dim FindString As String

    Application.ScreenUpdating = False
    Set ws1 = Sheet1    'NewMel
    Set ws2 = Sheet2    'OldMel

    lr1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lr2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
    Set rng2 = ws2.Range("A2:A" & lr2)

    'With each value in OldMel Column A, find it in
    'NewMel Column A;  if found, replace NewMel row with OldMel row;
    'if not found do nothing

    For Each cel2 In rng2    'OldMel
        FindString = cel2.Value
        If Trim(FindString) <> "" Then
            With ws1.Range("A2:A" & lr1)
                Set rng1 = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
                If Not rng1 Is Nothing Then
                    '                    Application.Goto rng1, True
                    ws2.Range("A" & cel2.Row).EntireRow.Copy
                    ws1.Range("A" & rng1.Row).PasteSpecial
                    Application.CutCopyMode = False
                End If
            End With
        End If
    Next cel2
    Application.ScreenUpdating = True
End Sub

Hi dmreno

A while I'd think...let me know how it goes.

Hey John,

I finally was able to get it to run on the the main file. Both worked and it took only 5 minutes to run on the 22 K row of information. We are still not sure why they were hangin up on the older files I had, but I did creat a whole new one and it ran perfectly. Thanks again for all your help..

Once again you came through with excellent code that works flawlessly and I greatly appreciate it very much.

David