3

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

enter image description here

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

enter image description here

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,

Improve this question
1
  • Sheet1 is sheet's Code name. It is not same with sheets(1). It appears in the project explorer in vb, which is different from the sequential index number of the sheet. I think you might have used it chaotically because you're in a file and not in another file. Commented Apr 22, 2020 at 14:02

3 Answers 3

Reset to default
2

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
Improve this answer
Sign up to request clarification or add additional context in comments.

9 Comments

Thank you, that's a lot more complicated than I thought it would be. The end result was very close, it just has duplicates of names now. link
To avoid duplicate values you might consider the use of a Dictionary
@Jehhred, I improved my answer.
@Dy.Lee Still duplicates on my end
@Jehhred, What about your before data?
|
1

here's a possible application of Dictionary object and Range.Sort() method:

Sub TwoLists()
    Dim MasterListRows As Long, WeeklyListRows As Long

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

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

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim cel As Range
    For Each cel In MasterListRange
        dict(UCase(cel.Value)) = 1
    Next

    For Each cel In WeeklyListRange
        dict(UCase(cel.Value)) = cel.Value
    Next

    Range("F2").Resize(dict.Count) = Application.Transpose(dict.keys)
    Range("G2").Resize(dict.Count) = Application.Transpose(dict.items)
    Range("F2:G2").Resize(dict.Count).Sort key1:=Range("F1")
    With Range("G2").Resize(dict.Count)
        If WorksheetFunction.CountA(.Cells) > 0 Then .SpecialCells(xlCellTypeConstants, xlNumbers).ClearContents
    End With

End Sub

BTW I don't get why you are sizing MasterListRows to column A and WeeklyListRows to column B last not empty cells row index while MasterListRange and WeeklyListRange are in column D and E respectively: you may want to use:

MasterListRows = Sheet1.Cells(Rows.Count, 4).End(xlUp).Row
WeeklyListRows = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row

instead

Improve this answer

4 Comments

Just tried this on another computer and it worked, Thank you!
Fine. I tested it before posting, so it had to work. And it must not depend on the computer unless you have a MAC. You may mark answer as accepted to direct future readers, too...Thanks
Like your approach. - FYI You might be interested in my (late) answer demonstrating a combination between array methods and newer Office 365 functions :+)
@HTH With the following: With Range("G2").Resize(dict.Count) If WorksheetFunction.CountA(.Cells) > 0 Then .SpecialCells(xlCellTypeConstants, xlNumbers).ClearContents End With Is there anyway to bypass the pastespecial if both lists are perfectly matching i.e. no changes were needed to be made. On perfect lists I get a Run-time 1004: No cells found error message.
1

Alternative approach using arrays plus Excel Office 365 functions

"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?"

My stimulus to this (late) answer was to demonstrate a tricky combination of array methods and transformations via Application.Index() and Application.Match() (avoiding btw mostly Ifs or loops) with the new dynamic Office 365 functions SORT() and UNIQUE().

The UNIQUE function returns a list of unique values in a list or range. Applying Evaluate on these `WorksheetFunctions allows to assign the found values to a 2-dim array, e.g.

myArray = Evaluate("=SORT(UNIQUE(D2:D17))")

Caveat:

This function is currently available to Office 365 subscribers in the Monthly channel. It will be available to Office 365 subscribers in the Semi-Annual channel starting in July 2020.

My intention is to show an interesting alternative to usual loops, but not to compete with the solution above by fastness or beauty.

Example call

Sub testUnique()
With Sheet1
    '[1a] get lastRows (differ from values in D:E, see OP!)
    Dim MasterListRows As Long, WeeklyListRows As Long
    MasterListRows = .Cells(.Rows.Count, 1).End(xlUp).Row
    WeeklyListRows = .Cells(.Rows.Count, 2).End(xlUp).Row
    '[1b] get related ranges
    Dim MasterListRange As Range, WeeklyListRange As Range
    Set MasterListRange = .Range("D2:D" & MasterListRows)
    Set WeeklyListRange = .Range("E2:E" & WeeklyListRows)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '[2] get complete set of all uniques in columns D:E
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '    Caveat: function uses Office365 UNIQUE() + SORT()
    Dim allUniques
    allUniques = getUniques(MasterListRange, WeeklyListRange)

    '[3] write results to target
    Dim tgt As Range
    Set tgt = .Range("F2").Resize(UBound(allUniques), 1)
    'write uniques to columns F:G
    tgt.Resize(Columnsize:=2) = allUniques     ' needs 2 columns

    '(optional/cosmetic) - adapt upper case vs proper case
    tgt.Offset(0, 0) = Evaluate("UPPER(" & tgt.Address & ")")
    tgt.Offset(0, 1) = Evaluate("PROPER(" & tgt.Offset(0, 1).Address & ")")

End With


End Sub

Help functions

Function getUniques(aRange As Range, bRange As Range)
    Dim a As Long: a = aRange.Rows.Count
    Dim b As Long: b = bRange.Rows.Count
    'add bRange items to aRange
    Dim addedRange As Range
    Set addedRange = aRange.Offset(a).Resize(b, 1)
    addedRange.Value = bRange.Value                       ' add bRange items temporarily to get all
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'get all uniques as 1-based 2-dim "vertical" array ...
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim all: all = Evaluate("=SORT(UNIQUE(D2:D" & (a + b + 1) & "))")
    '...and add 2nd column (needed in OP)
    all = Application.Index(all, Evaluate("row(1:" & UBound(all) & ")"), Array(1, 1))
    addedRange = vbNullString             ' clear temporary items in addedRange

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'identify master elements not contained in weeklyListRange
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '(1-based 2-dim array with either row numbers of found elements or Error value 2042)
    Dim nums: nums = Compare(aRange, bRange, bSort:=True)  ' << see function Compare() below
    '...remove not existing weekly list items in corresponding row (2nd column)
    Dim i As Long
    For i = 1 To UBound(nums)
        If IsError(nums(i, 1)) Then all(i, 2) = "***"      ' empty 2nd column
    Next i
    'return all as function result
    getUniques = all
    End Function

    Function Compare(aRange As Range, bRange As Range, Optional bSort As Boolean = False)
    'Note   : called by the above help function
    'Purpose: check the aRange array and return a 1-based 2-dim array containing
    '         a) row numbers of corresponding elements in bRange or
    '         b) Error value 2042 entries
    'Hint   : note that the 2nd MATCH argument is also a 1-dim array (differring from usual function calls)
    Dim a, b
    If bSort Then
        a = Evaluate("=SORT(" & aRange.Address & ")")
        b = Application.Transpose(Evaluate("=SORT(" & bRange.Address & ")"))
    Else
        a = aRange: b = Application.Transpose(bRange)
    End If
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Compare = Application.Match(a, b, 0)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    End Function
Improve this answer

1 Comment

I know there is such a feature, but I haven't used 365 yet, so I haven't applied it. Good content.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.