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。