Excel的VBA：循环通过在Sheet1两列，查找特定的名称，粘贴行与匹配值到Sheet2

Question

语境：新来VBA

任务：我在Worksheet1联系人列表中包含的列：姓氏，名字，电子邮件，电话号码等等。我在Worksheet2第二联系人列表（格式完全一样），其中包含大约在Worksheet1联系人列表但更新的联系人信息（电子邮件，电话号码等），发现1000名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。