如何比较两张工作表并使用 VBA 生成新列表？

Question

事先请注意，我刚刚开始使用 VBA，在此之前我几乎没有编码经验。

我有两张纸：

• 公开
• 联系人

A 列上有一个参数肯定在“联系人”表上，但可能在或不在“公共”表的 A 列上。

我正在做的是：

检查参数contacts.A2是否在public.A2上。

如果是，我需要按照确切的顺序复制列：

公开：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 行，因为它们是标题；
• 消除上面的 de IF，因为我不需要“NO MATCH”
• 到要根据 A 列按升序排列的结果列表。

你能帮帮我吗？

---

经过编辑以包含数据样本和预期结果：

我相信我可以通过上面的图片简化我的需求。我想在公共表上检查一个客户，从联系人表中获取经理联系人（电子邮件），并在结果表上创建一个包含分支、经理和这两个电子邮件的列表。

创建这些图像时，我意识到我忘记考虑第二个参数（经理），因为一个分支上可能有多个经理。所以这是另一个需要考虑的参数。

`Public sheet (image)

Contacts sheet(image)

Result sheet(image)

spreadsheet

`

Answer 1

正如大卫所建议的，最好有一个输入和输出样本。也许你可以试试这个：

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

Answer 2

根据我的 cmets 和您更新的示例问题，我相信您当前的结果与您所说的不符；它正在寻找参数“Branch”和“Manager”。您的预期结果也不像您想要根据您的问题提取的列。但是，根据您的示例数据和预期输出，我尝试了以下操作：

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

这个解决方案利用了应该很快的数组和字典。它给了我以下结果：