Comparing Two Lists - VBA

Question

I'm trying to compare and match two lists in Excel using VBA. I can't use a Vlookup function as one of the lists is generated using different software and is then exported into a new workbook every week. For illustrative purposes;

Two List Before

As shown in the image above, the names already match for the most part, and generally will only need to be moved one cell down to match. Below is what I want the end result to be. I normally do this manually but figured there has to be a way to simultaneously go through each name in both lists to check that each row matches, and then if they don't, one of two actions takes place;

If MasterList contains a name that WeeklyList Doesn't, leave a space in WeeklyList - as shown with Ebony.

If WeeklyList contains a name that MasterList doesn't, add that name to the MasterList in it's corresponding alphabetical order - as shown with Sally.

Two List After

I'm assuming this can be achieved using Loops and a few IF statements, just not sure whether this should be put into an array or dictionary?

So far I've established the dynamic rows - as shown below.

Sub TwoLists()

MasterListRows = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
WeeklyListRows = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row

Set MasterListRange = Sheet1.Range("D2:D" & MasterListRows)
Set WeeklyListRange = Sheet1.Range("E2:E" & WeeklyListRows)

End Sub

Any help is appreciated!

Thank you,

Answer 1

Try,

Sub TwoLists()
    Dim Masterlistrange As Range
    Dim WeeklyListRange As Range
    Dim vMaster As Variant
    Dim vWeek As Variant
    Dim MasterListRows As Long
    Dim WeeklyListRows As Long
    Dim vR() As Variant
    Dim i As Long, n As Long, j As Long
    Dim isExist As Boolean
    Dim Ws As Worksheet

    MasterListRows = Sheet1.Cells(Rows.Count, 4).End(xlUp).Row '<~~ Correct column number
    WeeklyListRows = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row '<~~ Correct column number

    Set Masterlistrange = Sheet1.Range("D2:D" & MasterListRows)
    Set WeeklyListRange = Sheet1.Range("E2:E" & WeeklyListRows)

    vMaster = Masterlistrange
    vWeek = WeeklyListRange

    For i = 1 To UBound(vWeek, 1)
        If WorksheetFunction.CountIf(Masterlistrange, UCase(vWeek(i, 1))) Then
            n = n + 1
            ReDim Preserve vR(1 To 2, 1 To n)
            vR(1, n) = UCase(vWeek(i, 1))
            vR(2, n) = vWeek(i, 1)
        Else
            n = n + 1
            ReDim Preserve vR(1 To 2, 1 To n)
            vR(1, n) = UCase(vWeek(i, 1))
            vR(2, n) = vWeek(i, 1)
        End If
    Next i
    For j = 1 To UBound(vMaster, 1)
        isExist = False
        For i = 1 To UBound(vWeek, 1)
            If vMaster(j, 1) = UCase(vWeek(i, 1)) Then
                isExist = True
                Exit For
            End If
        Next i
        If Not isExist Then
            n = n + 1
            ReDim Preserve vR(1 To 2, 1 To n)
            vR(1, n) = vMaster(j, 1)
        End If
    Next j
    Set Ws = Sheets.Add '<~~ Sheets("Your seetname")
    With Ws
        .Range("a1").Resize(1, 2) = Sheet1.Range("d1").Resize(1, 2).Value
        .Range("a2").Resize(n, 2) = WorksheetFunction.Transpose(vR)
        .Range("a1").CurrentRegion.Sort .Range("a1"), xlAscending, Header:=xlYes
    End With
End Sub

Remove Duplicated

Sub TwoLists2()
    Dim Masterlistrange As Range
    Dim WeeklyListRange As Range
    Dim vMaster As Variant
    Dim vWeek As Variant
    Dim MasterListRows As Long
    Dim WeeklyListRows As Long
    Dim vR() As Variant
    Dim i As Long, n As Long, j As Long
    Dim isExist As Boolean
    Dim Ws As Worksheet
    Dim Dic(1 To 2) As Object
    Dim s As String

    MasterListRows = Sheet1.Cells(Rows.Count, 4).End(xlUp).Row '<~~ Correct column number
    WeeklyListRows = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row '<~~ Correct column number

    Set Masterlistrange = Sheet1.Range("D2:D" & MasterListRows)
    Set WeeklyListRange = Sheet1.Range("E2:E" & WeeklyListRows)

    vMaster = Masterlistrange
    vWeek = WeeklyListRange

    For i = 1 To 2
        Set Dic(i) = CreateObject("Scripting.Dictionary")
    Next i

    For i = 1 To UBound(vWeek, 1)
        s = UCase(vWeek(i, 1))
        If Not Dic(1).Exists(s) Then
            Dic(1).Add s, s

            If WorksheetFunction.CountIf(Masterlistrange, s) Then
                n = n + 1
                ReDim Preserve vR(1 To 2, 1 To n)
                vR(1, n) = s
                vR(2, n) = vWeek(i, 1)
            Else
                n = n + 1
                ReDim Preserve vR(1 To 2, 1 To n)
                vR(1, n) = UCase(vWeek(i, 1))
                vR(2, n) = vWeek(i, 1)
            End If
        End If
    Next i
    For j = 1 To UBound(vMaster, 1)
        isExist = False
        s = vMaster(j, 1)
        If Not Dic(2).Exists(vMaster(j, 1)) Then
            Dic(2).Add s, s
            For i = 1 To UBound(vWeek, 1)
                If s = UCase(vWeek(i, 1)) Then
                    isExist = True
                    Exit For
                End If
            Next i
            If Not isExist Then
                n = n + 1
                ReDim Preserve vR(1 To 2, 1 To n)
                vR(1, n) = s
            End If
        End If
    Next j
    Set Ws = Sheets.Add '<~~ Sheets("Your seetname")
    With Ws
        .Range("a1").Resize(1, 2) = Sheet1.Range("d1").Resize(1, 2).Value
        .Range("a2").Resize(n, 2) = WorksheetFunction.Transpose(vR)
        .Range("a1").CurrentRegion.Sort .Range("a1"), xlAscending, Header:=xlYes
    End With
End Sub