CODEWITHSUNDEEP
excelvba
Coles
Coles

Reputation: 25

Excel VBA: Loop through two columns in sheet1, look for specific names, paste rows with matching value to sheet2

Context: New to VBA

Task: I have a contact list in Worksheet1 which contains columns: LastName, FirstName, email, phone #, and several more. I have a second contact list in Worksheet2 (formatted exactly the same) which contains approximately 500 of the 1,000 names found in the Worksheet1 contact list BUT with updated contact information (email, phone #, etc.). I'm trying to write code to find which names are in both worksheets, and for those names, copy the email, phone#, etc. from Worksheet2 (updated information) and paste it into the corresponding location in Worksheet2.

Code: This is what I have so far. It does not work.

 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

Any help is greatly appreciated!

Thanks

Upvotes: 1

Views: 69

Answers (1)

Ralph
Ralph

Reputation: 9434

Here is a working solution with some minor improvements such as Option Explicit, fully qualified references at all times, Option Compare Text to ignore capital letters when comparing the names, Trim to ignore possible leading or trailing spaces, and creating another outer loop to do the comparison for all names on 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

If the code is running slow you might want to consider using an array: (1) put the entire sheet shtUpdatedContacts into an array as well as the sheet shtContactList and (2) then make the search / comparison there. (3) Finally, paste the updates array back to sheet shtContactList.

Upvotes: 1

Related Questions