Comparing Multiple Criteria Across Two Worksheets to Find and Migrate Rows

[reberryjr]

I'm trying to find a way to identify instances from my Incoming Volume worksheet, that do not exist on my Working Population worksheet, and copy them over to the Working Population worksheet. I think I'm good on how to copy and paste, but I'm not certain on the best method to go through each row on the Incoming Volume worksheet, and determine if the record exists on the Working Population worksheet.

I would want to move record over if the value in column H and the value in column Q of the Incoming Volume worksheet does not match the value in column O and X of the Working Population worksheet.

Incoming Volume
Column H = AcctNbr
Column Q = Notified

Working Population
Column O = AcctNbr
Column X = Notified

 

[mumps]

When you say "I would want to move record over" do you mean that you would want to move the entire row where the columns don't match to the first available row in the Working Population worksheet or do you want to copy the row?

 

[reberryjr]

@mumps, I would want to copy the row. Once the comparison and data migration is complete, I'll just wind up deleting the "from" sheet.

 

[mumps]

This macro assumes that column A in Sheets("Incoming Volume") will always have data.

Sub CompareData()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    Sheets("Working Population").Select
    For Each Rng In Range("O2", Range("O" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value & Rng.Offset(0, 9)) Then
            RngList.Add Rng.Value & Rng.Offset(0, 9), Nothing
        End If
    Next
    Sheets("Incoming Volume").Select
    For Each Rng In Range("H2", Range("H" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value & Rng.Offset(0, 9)) Then
            Rng.EntireRow.Copy Sheets("Working Population").Cells(Sheets("Working Population").Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub

If you want the macro to delete the "Incoming Volume" sheet after the data migration is complete, add these lines of code:

Application.DisplayAlerts = False
Sheets("Incoming Volume").Delete
Application.DisplayAlerts = True

below this line:

RngList.RemoveAll

 

[reberryjr]

@mumps, thank you for this. A couple of questions. It only appears to be evaluating the first row, not the entire sheet. Or, am I missing how it's evaluating everything?

Neither of the worksheets will consistently have data in column A. Instead, the Incoming Volume sheet will always have data in column H, and the Working Population sheet will always have data in column O.

Your code goes a different route than what I was contemplating, so I do have a question about the copy/paste. Essentially, where the record on the Incoming Volume sheet is unique, I'd need to copy range H : BB and paste it into range O & LastRow + 1 on the Working Population sheet.

 

[mumps]

Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary")
    Sheets("Working Population").Select
    For Each Rng In Range("O2", Range("O" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value & Rng.Offset(0, 9)) Then
            RngList.Add Rng.Value & Rng.Offset(0, 9), Nothing
        End If
    Next
    Sheets("Incoming Volume").Select
    For Each Rng In Range("H2", Range("H" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value & Rng.Offset(0, 9)) Then
            Range("H" & Rng.Row & ":BB" & Rng.Row).Copy Sheets("Working Population").Cells(Sheets("Working Population").Rows.Count, "O").End(xlUp).Offset(1, 0)
        End If
    Next
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub

 

[reberryjr]

@mumps, thank you so much! It works. I'm not entirely sure how all of it works just yet, but it works!

 

[mumps]

You are very welcome. Here is the code with some explanatory comments:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object
    Set RngList = CreateObject("Scripting.Dictionary") 'creates dictionary to store data
    Sheets("Working Population").Select
    For Each Rng In Range("O2", Range("O" & Rows.Count).End(xlUp)) 'loops through column O
        If Not RngList.Exists(Rng.Value & Rng.Offset(0, 9)) Then 'if the concatenated values of cells in column O and column X are not in dicitonary...
            RngList.Add Rng.Value & Rng.Offset(0, 9), Nothing 'adds the concatenated values of cells in column O and column X
        End If
    Next
    Sheets("Incoming Volume").Select
    For Each Rng In Range("H2", Range("H" & Rows.Count).End(xlUp)) 'loops through column H
        If Not RngList.Exists(Rng.Value & Rng.Offset(0, 9)) Then 'if the concatenated values of cells in column H and column Q are not in dicitonary, ie they are unique.....
            Range("H" & Rng.Row & ":BB" & Rng.Row).Copy Sheets("Working Population").Cells(Sheets("Working Population").Rows.Count, "O").End(xlUp).Offset(1, 0) 'copies range
        End If
    Next
    RngList.RemoveAll 'empties dictionary
    Application.ScreenUpdating = True
End Sub

 

[reberryjr]

@mumps, I need some help again. There were some changes made to the workbooks and the ask, but the theory is the same. Now, I need to find the unique records on a workbook called "BKR417" (instead of a sheet in the same workbook). Paste the differences in the first available cell in column R of the receiving workbook. I tried adapting the code above, but nothing is pasting, and I'm not getting any errors. When I step through the code, it seems to hit the lines in red font, but only cycles through Ln 27 - Ln 30, with no action being taken.

Thoughts?

Sub IngestIncomingVolume()
Application.ScreenUpdating = False
Dim iVol, mVol As Workbook
Dim iws2, mws2 As Worksheet
Dim Rng As Range
Dim RngList As Object
Set mVol = ThisWorkbook
Set mws2 = ThisWorkbook.Sheets("Active_Inv")
Set iRngList = CreateObject("Scripting.Dictionary")
On Error Resume Next
Set iVol = Workbooks.Open("FilePath is Here")
Set iws2 = iVol.Sheets("New Notification OD Detail")

Workbooks("DepApp v1").Activate
Sheets("Active_Inv").Select
For Each Rng In Range("R2", Range("R" & Rows.Count).End(xlUp))
    If Not RngList.exists(Rng.Value & Rng.Offset(0, 9)) Then
        RngList.Add Rng.Value & Rng.Offset(0, 9), Nothing
    End If

Next

Workbooks("BKR417").Activate
Sheets("New Notification OD Detail").Select
For Each Rng In Range("H2", Range("H" & Rows.Count).End(xlUp))
[COLOR=#FF0000]    If Not RngList.exists(Rng.Value & Rng.Offset(0, 9)) Then
        Range("H" & Rng.Row & ":BB" & Rng.Row).Copy Workbooks("DepApp v1").Sheets("Active_Inv").Cells(Sheets("Active_Inv").Rows.Count, "R").End(xlUp).Offset(1, 0)
    End If[/COLOR]
Next
    
RngList.RemoveAll
Application.ScreenUpdating = True
End Sub

 

[mumps]

I tidied up the code a bit. See if this works for you:

Sub IngestIncomingVolume()
    Application.ScreenUpdating = False
    Dim iVol As Workbook, mVol As Workbook
    Dim iws2 As Worksheet, mws2 As Worksheet
    Dim Rng As Range
    Dim RngList As Object
    Set mVol = ThisWorkbook
    Set mws2 = ThisWorkbook.Sheets("Active_Inv")
    Set iRngList = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    Set iVol = Workbooks.Open("FilePath is Here")
    Set iws2 = iVol.Sheets("New Notification OD Detail")
    For Each Rng In mws2.Range("R2", mws2.Range("R" & mws2.Rows.Count).End(xlUp))
        If Not RngList.exists(Rng.Value & Rng.Offset(0, 9)) Then
            RngList.Add Rng.Value & Rng.Offset(0, 9), Nothing
        End If
    Next
    For Each Rng In iws2.Range("H2", iws2.Range("H" & iws2.Rows.Count).End(xlUp))
        If Not RngList.exists(Rng.Value & Rng.Offset(0, 9)) Then
            iws2.Range("H" & Rng.Row & ":BB" & Rng.Row).Copy mws2.Cells(mws2.Rows.Count, "R").End(xlUp).Offset(1, 0)
        End If
    Next
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub