Excel 比较两个列表-VBA

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

前两张名单

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

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

如果WeeklyList包含一个主列表中没有的名称，则按其相应的字母顺序将该名称添加到主列表中，如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

感谢您的帮助

谢谢，

试试看

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

子列表（）
调暗主列表范围作为范围
朦胧的一周，像射程一样奇怪
Dim vMaster作为变体
Dim vWeek作为变体
暗淡的主列表行与长的行相同
朦胧的周线和长的一样
Dim vR（）作为变量
暗i为长，n为长，j为长
Dim isExist为布尔型
将Ws设置为工作表
MasterListRows=Sheet1.Cells（Rows.Count，4）.End（xlUp）.Row'这是
字典
对象和
范围.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列last not empty cells行索引，而
masterlistrage
和
WeeklyListRange
分别位于D列和E列：您可能需要使用：

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

相反
使用阵列和Excel Office 365功能的替代方法

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

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

我对这个（后期）答案的刺激是演示数组方法和变换的巧妙组合
通过
Application.Index（）
和
Application.Match（）
（如果
s或循环，请尽量避免使用
If
和
UNIQUE（）
的新的动态Office 365功能

返回列表或范围中唯一值的列表。
在这些“工作表”函数上应用
Evaluate
，可以将找到的值分配给二维数组，例如

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

谢谢，这比我想象的要复杂得多。最终的结果非常接近，它现在只有重复的名字。为了避免重复的值，您可能会考虑使用@ JeHHRID，我改进了我的回答。end@Jehhred，那么您以前的数据呢？刚刚在另一台计算机上尝试了这个，它成功了，谢谢！好的我在发布之前测试了它，所以它必须工作。除非你有MAC电脑，否则它不能依赖于电脑。您也可以将答案标记为已接受，以指导未来的读者…感谢您的方法。-仅供参考，您可能会对我（晚些时候）的答案感兴趣，该答案演示了数组方法和较新的Office 365函数的组合：+）@HTH，内容如下：
范围（“G2”）。如果工作表函数.CountA（.Cells）>0，则调整大小（dict.Count）。特殊单元格（xlCellTypeConstants，xlNumbers）.ClearContents以
结尾。如果两个列表完全匹配，即不需要进行任何更改，是否仍可以绕过pastespecial。在完美列表中，我得到一条运行时1004：未找到单元格错误消息。Sheet1是工作表的代码名。这与图纸（1）不同。它出现在vb中的project explorer中，与图纸的顺序索引号不同。我想你可能会乱用它，因为你在一个文件中，而不是在另一个文件中。我知道有这样一个功能，但我还没有使用365，所以我还没有应用它。内容很好。
    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