Question

上下文： VBA新手

任务：我在Worksheet1中有一个联系人列表，其中包含列：LastName，FirstName，email，phone＃等等。我在Worksheet2中有第二个联系人列表（格式完全相同），其中包含工作表1联系人列表中找到的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。

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

1 个答案: