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

Question

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

我有两个 sheet：

public
联系人

A 列上有一个参数肯定在 "contacts" sheet 上，但可能在或不在 "public" sheet 上的 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 行，因为它们是 headers；
消除上面的 de IF，因为我不需要 "NO MATCH"
根据 A 列升序排列结果列表。

你能帮帮我吗？

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

我相信我可以用上面的图片简化我的需求。我想查看 public sheet 上的客户，从联系人 sheet 中获取经理联系人（电子邮件），并创建一个包含分支机构、经理和两者的列表 e-mails 结果 sheet.

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

`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

根据我的评论和您更新后的示例问题，我相信您当前的结果与您所说的要求不符；它正在寻找参数 "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

此解决方案使用数组和字典，速度应该很快。它给了我以下结果：

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

How can I compare two sheets and generate a new list using VBA?

excel

vba

loops

list

paste