Сравнение двух списков - VBA

Question

Я пытаюсь сравнить и сопоставить два списка в Excel, используя VBA. Я не могу использовать функцию Vlookup, поскольку один из списков создается с использованием другого программного обеспечения, а затем каждую неделю экспортируется в новую рабочую книгу. Для наглядности:

Два списка перед

Как показано на рисунке выше, имена по большей части уже совпадают, и, как правило, нужно будет переместить только одну ячейку вниз, чтобы соответствовать. Ниже я хочу, чтобы конечный результат был. Обычно я делаю это вручную, но решил, что должен быть способ одновременного go через каждое имя в обоих списках, чтобы проверить соответствие каждой строки, а затем, если они не совпадают, происходит одно из двух действий;

Если MasterList содержит имя, которого нет в WeeklyList, оставьте пробел в WeeklyList - как показано на Ebony.

Если WeeklyList содержит имя, которого нет в MasterList, добавьте это имя в MasterList в соответствующем в алфавитном порядке - как показано с Салли.

Два списка после

Я предполагаю, что это может быть достигнуто с помощью циклов и Несколько операторов IF, просто не уверен, стоит ли это помещать в массив или словарь?

До сих пор я установил динамические c строки - как показано ниже.

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

Альтернативный подход с использованием массивов плюс функции Excel Office 365

"Я предполагаю, что это может быть достигнуто с помощью циклов и нескольких операторов IF, просто не уверен должно ли это быть помещено в массив или словарь? "

Мой стимул , чтобы этот (поздний) ответ должен был продемонстрировать хитрую комбинацию методов массива и преобразования через Application.Index() и Application.Match() (исключая, между прочим, в основном If с или циклы) с новыми динамическими c функциями Office 365 SORT() и UNIQUE().

Функция UNIQUE возвращает список уникальных значений в списке или диапазоне. Применение Evaluate к этим ` WorksheetFunctions позволяет присвоить найденные значения 2-мерному массиву, например,

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

Предупреждение:

Эта функция в настоящее время доступна подписчикам Office 365 на ежемесячном канале. Он будет доступен для подписчиков Office 365 на полугодовом канале, начинающемся в июле 2020 года.

Мое намерение - показать интересную альтернативу обычным циклам, но не конкурировать с решением выше по скорости или красота.

Пример вызова

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

Answer 3

вот возможное применение 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

вместо