比较两个列表 - VBA

Question

我正在尝试使用 VBA 比较和匹配 Excel 中的两个列表。我不能使用 Vlookup 功能，因为其中一个列表是使用不同的软件生成的，然后每周都会导出到一个新的工作簿中。用于说明目的；

之前的两个列表

如上图所示，名称大部分已经匹配，通常只需向下移动一个单元格即可匹配。下面是我想要的最终结果。我通常手动执行此操作，但认为必须有一种方法可以同时检查两个列表中的每个名称以检查每一行是否匹配，然后如果它们不匹配，则执行两个操作之一；

如果 MasterList 包含 WeeklyList 不包含的名称，请在 WeeklyList 中留一个空格 - 如 Ebony 所示。

如果 WeeklyList 包含 MasterList 不包含的名称，请按相应的字母顺序将该名称添加到 MasterList - 如 Sally 所示。

两个列表之后

我假设这可以使用循环和一些 IF 语句来实现，只是不确定是否应该将其放入数组或字典中？

到目前为止，我已经建立了动态​​行 - 如下所示。

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

感谢任何帮助！

谢谢，

Answer 1

试试，

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

删除重复

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

Answer 2

这是Dictionary 对象和Range.Sort() 方法的可能应用：

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

顺便说一句，我不明白为什么您将 MasterListRows 调整为 A 列，WeeklyListRows 调整为 B 列最后不是空单元格行索引，而 MasterListRange 和 WeeklyListRange 分别位于 D 列和 E 列：您可以想用：

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

改为

Answer 3

使用数组和 Excel Office 365 函数的替代方法

“我假设这可以使用循环和一些 IF 语句来实现，只是不确定是否应该将其放入数组或字典中？”

我对这个（迟到的）答案的刺激是展示数组方法和转换的巧妙组合 通过Application.Index() 和Application.Match() （避免btw 主要是Ifs 或循环） 使用新的动态Office 365 功能 SORT() 和UNIQUE()。 p>

UNIQUE function 返回列表或范围中唯一值的列表。 在这些 `WorksheetFunctions 上应用 Evaluate 允许将找到的值分配给 2-dim 数组，例如

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

警告：

此功能目前在每月频道中可供 Office 365 订阅者使用。 从 2020 年 7 月开始，Office 365 订阅者可以在半年频道中使用它。

我的目的是展示一个有趣的替代常规循环的方法， 但不要以速度或美观与上述解决方案竞争。

调用示例

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

帮助功能

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