Excel VBA：遍历sheet1中的两列，查找特定名称，将具有匹配值的行粘贴到sheet2

Question

上下文： VBA 新手

任务：我在 Worksheet1 中有一个联系人列表，其中包含以下列：姓氏、名字、电子邮件、电话号码等。我在 Worksheet2 中有第二个联系人列表（格式完全相同），其中包含 Worksheet1 联系人列表中找到的 1,000 个姓名中的大约 500 个，但包含更新的联系信息（电子邮件、电话号码等）。我正在尝试编写代码来查找两个工作表中的名称，对于这些名称，从 Worksheet2 复制电子邮件、电话号码等（更新信息）并将其粘贴到 Worksheet2 中的相应位置。

代码：这是我目前所拥有的。它不起作用。

 Sub UpdateContacts()

 Dim Reference As String
 Dim Range As Range
 Dim ContactList As Worksheet
 Dim UpdatedContacts As Worksheet

 ContactList = ActiveWorkbook.Sheets("Contact List")
 UpdatedContacts = ActiveWorkbook.Sheets("Updated Contacts")

 Reference = ContactList.Range("B5", "C5").Value

 j = 5

 For i = 5 To UpdatedContacts.Cells(Rows.Count, 1).End(xlUp).Row

      If UpdatedContacts.Range(Cells(i, 2), Cells(i, 3)).Value = Reference Then
           UpdatedContacts.Range(Cells(i, 4), Cells(i, 17)).Copy _
           Destination:=ContactList.Range(Cells(j, 4), Cells(j, 17))
           j = j + 1
      End If
    Next i
End Sub

非常感谢任何帮助！

谢谢

Answer 1

这是一个有效的解决方案，有一些小的改进，例如 Option Explicit、始终完全限定的引用、Option Compare Text 在比较名称时忽略大写字母、Trim 忽略可能的前导或尾随空格，以及创建另一个外部循环对shtContactList 上的所有名称进行比较：

Option Explicit
Option Compare Text

Sub UpdateContacts()

Dim ws As Worksheet
Dim rngCell As Range
Dim i As Long, j As Long
Dim strReference As String
Dim shtContactList As Worksheet
Dim shtUpdatedContacts As Worksheet

For Each ws In ThisWorkbook.Worksheets
    Select Case ws.Name
        Case "Contact List"
            Set shtContactList = ws
        Case "Updated Contacts"
            Set shtUpdatedContacts = ws
        Case Else
            Debug.Print ws.Name
    End Select
Next ws
If shtContactList Is Nothing Or shtUpdatedContacts Is Nothing Then
    MsgBox "One or more required sheet(s) were not found." & Chr(10) & "Aborting..."
    Exit Sub
End If

For j = 5 To shtContactList.Cells(shtContactList.Rows.Count, "A").End(xlUp).Row
    strReference = Trim(shtContactList.Cells(j, 2).Value2) & ", " & Trim(shtContactList.Cells(j, 3).Value2)
    For i = 5 To shtUpdatedContacts.Cells(shtUpdatedContacts.Rows.Count, 1).End(xlUp).Row
        If Trim(shtUpdatedContacts.Cells(i, 2).Value2) & ", " & Trim(shtUpdatedContacts.Cells(i, 3).Value2) = strReference Then
            shtUpdatedContacts.Range(shtUpdatedContacts.Cells(i, 4), shtUpdatedContacts.Cells(i, 17)).Copy _
                Destination:=shtContactList.Range(shtContactList.Cells(j, 4), shtContactList.Cells(j, 17))
            j = j + 1
        End If
    Next i
Next j

End Sub

如果代码运行缓慢，您可能需要考虑使用数组：(1) 将整个工作表 shtUpdatedContacts 以及工作表 shtContactList 放入一个数组中，(2) 然后在那里进行搜索/比较. (3) 最后，将更新数组粘贴回工作表shtContactList。