excel - 比较两个列表 - 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