Как я могу сравнить два листа и создать новый список, используя VBA?

Question

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

У меня есть два листа:

• public
• contacts

В столбце A есть один параметр, который определенно находится на листе «контакты», но может быть или нет в столбце A на «общедоступном» листе.

Что яЯ делаю это:

Проверка, если параметр contacts.A2 на public.A2.

Если это так, мне нужно скопировать столбцы, в точном порядке:

public: A, C, G. контакты: E, F.

Я нашел следующий код в сети, и у меня есть некоторые адаптации к нему, но я застрял.

Sub match()

Dim I, total, frow As Integer
Dim found As Range

total = Sheets("public").Range("A" & Rows.Count).End(xlUp).Row
'MsgBox (total) '(verifica se a contagem está ok)

For I = 2 To total
   pesquisa = Worksheets("public").Range("A" & I).Value
Set found = Sheets("contacts").Columns("A:A").Find(what:=pesquisa) 'finds a match

If found Is Nothing Then
    Worksheets("result").Range("W" & I).Value = "NO MATCH"
Else
    frow = Sheets("contacts").Columns("A:A").Find(what:=pesquisa).Row
    Worksheets("result").Range("A" & I).Value = Worksheets("public").Range("A" & frow).Value
    Worksheets("result").Range("B" & I).Value = Worksheets("public").Range("C" & frow).Value
    Worksheets("result").Range("C" & I).Value = Worksheets("public").Range("G" & frow).Value
    Worksheets("result").Range("D" & I).Value = Worksheets("contacts").Range("F" & frow).Value
    Worksheets("result").Range("E" & I).Value = Worksheets("contacts").Range("G" & frow).Value
End If
Next I
End Sub

Что я ожидаю:

• , чтобы код игнорировал строку 1, так как это заголовки;
• , чтобы исключить де IF выше, так как мне не нужно«НЕТ МАТЧА»
• к результирующему списку, который нужно упорядочить в порядке возрастания на основе столбца А.

Можете ли вы мне помочь?

---

отредактировано, чтобы включить образцы of Данные и ожидаемые результаты:

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

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

` Публичный лист (изображение)

Лист контактов (изображение)

Таблица результатов (изображение)

Таблица

`

Answer 1

Согласно моим комментариям и вашему обновленному вопросу с образцом, я считаю, что ваши текущие результаты не соответствуют тому, что вы говорите, требуется;который ищет оба параметра "Филиал" и "Менеджер". Ваш ожидаемый результат также не похож на столбцы, которые вы хотели извлечь в соответствии с вашим вопросом. Однако, следуя вашим образцам данных и ожидаемым результатам, я попробовал следующее:

Sub BuildList()

'Define your variables
Dim x As Long, y As Long
Dim arr1 As Variant, arr2 As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

'Fill 1st array variable from sheet Contacts
With Sheet1 'Change accordingly
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr1 = .Range("A2:D" & x).Value
End With

'Fill dictionary with first array
For x = LBound(arr1) To UBound(arr1)
    dict.Add arr1(x, 1) & "|" & arr1(x, 2), arr1(x, 3) & "|" & arr1(x, 4)
Next x

'Fill 2nd array variable from sheet Public
With Sheet2 'Change accordingly
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr2 = .Range("A2:B" & x).Value
End With

'Compare array against dictionary and fill sheet Results
With Sheet3 'Change accordingly
    y = 2
    For x = LBound(arr2) To UBound(arr2)
        If dict.Exists(arr2(x, 1) & "|" & arr2(x, 2)) Then
            .Cells(y, 1).Value = arr2(x, 1)
            .Cells(y, 2).Value = arr2(x, 2)
            .Cells(y, 3).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(0)
            .Cells(y, 4).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(1)
            y = y + 1
        End If
    Next x
End With

End Sub

В этом решении используются массивы и словарь, которые должны быть быстрыми. Это дало мне следующий результат:

Answer 2

Как предположил Дэвид, было бы лучше иметь образец ввода и вывода. Может быть, вы можете попробовать это:

Option Explicit

Public Sub match()

    Dim wsPub As Worksheet
    Dim wsCon As Worksheet
    Dim wsRes As Worksheet
    Dim pubRow As Long
    Dim conRow As Long
    Dim resRow As Long
    Dim i As Long
    Dim rng As Range
    Dim cel As Range
    Dim found As Long
    Dim order(1 To 5) As Integer

    Set wsPub = ThisWorkbook.Worksheets("public")
    Set wsCon = ThisWorkbook.Worksheets("contacts")
    Set wsRes = ThisWorkbook.Worksheets("result")
    pubRow = wsPub.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
    conRow = wsCon.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
    resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row
    Set rng = wsPub.Range("A2:A" & pubRow)
    order(1) = 1
    order(2) = 3
    order(3) = 7
    order(4) = 6
    order(5) = 7

    For Each cel In rng
        If Not IsError(Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0)) Then
            found = Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0) + 1
            resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row

            For i = 1 To 5
                If i < 4 Then
                    wsRes.Cells(resRow, i).Offset(1, 0).Value _
                    = cel.Offset(0, order(i) - 1).Value
                Else
                    wsRes.Cells(resRow, i).Offset(1, 0).Value _
                    = wsCon.Cells(found, order(i)).Value
                End If
            Next
        End If
    Next

    wsRes.Range("A1").AutoFilter
    wsRes.AutoFilter.Sort.SortFields.Clear
    wsRes.AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("A1:A" & resRow), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:= _
        xlSortNormal
    wsRes.AutoFilter.Sort.Apply

End Sub