Создайте один список из двух с помощью Excel VBA

Question

Я создаю приложение, чтобы сначала скопировать данные из одной рабочей книги в другую (это уже работает).

Затем следует самая сложная часть, в которой я пока не уверен, возможно ли это вообще. Существует два списка данных.

Первый (Лист1):

Второй (Лист2):

Код должен сравнить столбцы B и C и построить новый список с (Sheet3), который будет выглядеть следующим образом:

Итак, сначала построите Sheet3, после сравнения, если дубликат был найден, затем добавьте значение к соответствующему (столбец B). Если дубликат не найден, создайте новую строку с данными.

Вот мой код для обнаружения дубликатов.

Sub CheckAvailability()
Dim rMyRng As Range, rCompare As Range, r As Range, lFound As Long, blStatus As Boolean

Application.ScreenUpdating = False

With Sheets("Sheet1")
    Set rMyRng = .Range("B2:C" & Range("C" & Rows.Count).End(xlUp).row)
End With

With Sheets("Sheet2")
    Set rCompare = .Range("B2:C" & Range("C" & Rows.Count).End(xlUp).row)
End With

For Each r In rMyRng.Rows
    With r
        .Select
        blStatus = False
        lFound = Application.CountIfs(rCompare.Columns(1), .Cells(1).Value, rCompare.Columns(2), .Cells(2).Value)
        If lFound Then blStatus = True
        .Cells(2).Offset(, 1).Value = blStatus
    End With
Next r

Application.ScreenUpdating = True

End Sub

С моим текущим кодом я получаю это как вывод, это правильно. Как заставить все остальное работать?

Answer 1

другое словарное решение (не проверено):

Sub Main()
    Dim dict As Scripting.Dictionary
    Set dict = New Scripting.Dictionary

    Dim cell As Range
    With Worksheets("Sheet1")
        For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) = cell.Value2 & " "
        Next
    End With

    With Worksheets("Sheet2")
        For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) = dict(cell.Offset(, 1).Value2 & "|" & cell.Offset(, 2).Value2) & " " & cell.Value2
        Next
    End With

    Dim key As Variant
    Dim iRow As Long
    With Worksheets("Sheet3")
        For Each key In dict.Keys
            .Range("A1:B1").Offset(iRow).Value = Split(Replace(dict(key), "  ", " "), " ")
            .Range("C1:D1").Offset(iRow).Value = Split(key, "|")
            iRow = iRow + 1
        Next
    End With
End Sub

Answer 2

Не уверен, что это лучший способ, так как он довольно обширный, но хотелось попробовать какой-нибудь словарь =). Надеемся, что это полезно.

---

Массивы со словарем (объединены)

• Используются два массива, которые заполняются из обоихlists
• Итерация по первому массиву для загрузки элементов в словарь
• Итерация по второму массиву для проверки их наличия в словаре. Если это так, проверьте номер почтового ящика и действуйте соответственно
• Итерирует по словарю, чтобы преобразовать его значения в sheet3

---

Sub BuildList()

'Declare all the variables
Dim x As Long, arr1 As Variant, arr2 As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

'Fill 1st array from sheet1
With Sheet1
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr1 = .Range("A2:C" & x).Value
End With

'Fill 2nd array from sheet2
With Sheet2
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr2 = .Range("A2:C" & x).Value
End With

'Load 1st array into dictionary
For x = LBound(arr1) To UBound(arr1)
    dict.Add arr1(x, 2), arr1(x, 1) & "||" & arr1(x, 2) & "|" & arr1(x, 3)
Next x

'Load 2nd array into dictionary with test
For x = LBound(arr2) To UBound(arr2)
    If dict.Exists(arr2(x, 2)) Then
        If Trim(arr2(x, 3)) = Split(dict(arr2(x, 2)), "|")(3) Then
            dict(arr2(x, 2)) = Split(dict(arr2(x, 2)), "|")(0) & "|" & arr2(x, 1) & "|" & arr2(x, 2) & "|" & arr2(x, 3)
        Else
            dict.Add arr2(x, 2) & "x", "|" & arr2(x, 1) & "|" & arr2(x, 2) & "|" & arr2(x, 3)
        End If
    Else
        dict.Add arr2(x, 2), "|" & arr2(x, 1) & "|" & arr2(x, 2) & "|" & arr2(x, 3)
    End If
Next x

'Transpose dictionary into sheet3
With Sheet3
    x = 2
    For Each Key In dict.keys
        .Cells(x, 1).Resize(1, 4).Value = Split(dict(Key), "|")
        x = x + 1
    Next Key
End With

End Sub

---

Массивы со словарем (модуль класса)

Второй вариант, согласно моему комментарию, также включать модуль класса. Просто добавьте следующий модуль класса, и его имя будет clssList:

Public Number1 As Variant
Public Number2 As Variant
Public NameSpec As String
Public PostBox As Long

Теперь вместо предыдущего кода мы можем устанавливать новые объекты через этот модуль класса и заполнять их словарем:

Sub BuildListWithClss()

'Declare all the variables
Dim x As Long, arr1 As Variant, arr2 As Variant, lst As clssList
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

'Fill 1st array from sheet1
With Sheet1
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr1 = .Range("A2:C" & x).Value
End With

'Fill 2nd array from sheet2
With Sheet2
    x = .Cells(.Rows.Count, 3).End(xlUp).Row
    arr2 = .Range("A2:C" & x).Value
End With

'Load 1st array into dictionary with use of class
For x = LBound(arr1) To UBound(arr1)
    Set lst = New clssList
    lst.Number1 = arr1(x, 1)
    lst.NameSpec = arr1(x, 2)
    lst.PostBox = arr1(x, 3)
    dict.Add arr1(x, 2), lst
Next x

'Load 2nd array into dictionary with test
For x = LBound(arr2) To UBound(arr2)
    If dict.Exists(arr2(x, 2)) Then
        If Trim(arr2(x, 3)) = Trim(dict(arr2(x, 2)).PostBox) Then
            dict(arr2(x, 2)).Number2 = arr2(x, 1)
        Else
            Set lst = New clssList
            lst.Number2 = arr2(x, 1)
            lst.NameSpec = arr2(x, 2)
            lst.PostBox = arr2(x, 3)
            dict.Add arr1(x, 2) & "x", lst
        End If
    Else
        Set lst = New clssList
        lst.Number2 = arr2(x, 1)
        lst.NameSpec = arr2(x, 2)
        lst.PostBox = arr2(x, 3)
        dict.Add arr2(x, 2), lst
    End If
Next x

'Transpose dictionary into sheet3
With Sheet3
    x = 2
    For Each Key In dict.keys
        .Cells(x, 1).Value = dict(Key).Number1
        .Cells(x, 2).Value = dict(Key).Number2
        .Cells(x, 3).Value = dict(Key).NameSpec
        .Cells(x, 4).Value = dict(Key).PostBox
        x = x + 1
    Next Key
End With

Как видите, немного больше кода. Но IMO довольно чистый и простой для понимания, и он не будет укусить вас, если в одном из ваших имен будет символ «труба», как в моем предыдущем коде.