Combining/merging rows when a common e-mail address is found

**[email protected]** · 07-08-2013, 03:39 PM

I am having trouble drilling down a database of contacts that was recently passed on to me. Each contact can have up to five different phone numbers. Rather than having one entry per contact with all of the phone numbers itemized normally, anytime the phone number count exceeds one, a new entry is created for that contact with all identical information with the exception of the number. So for example, my table may look like:

Contact e-mail Phone Fax Cell
[email protected] 555-1234
[email protected] 555-4321
[email protected] 555-6789

I am trying to get a piece of code that can go down through the contact email, if the preceding cell is a duplicate move the phone number value up one row, delete the secondary row, and move on to the next row. My spreadsheet has about 4700 rows, so any automation tips that could be provided would be greatly appreciated!

**AlphaFrog** · 07-08-2013, 05:14 PM

Change the column letters in the code to suit. Test this on a copy of your data.

Sub Last_Pnone_Number()
    
    Const cMail As String = "A"     'Conlumn letter with the email data
    Const cPhone As String = "B"    'Column letter with the phone numbers
    Dim i As Long
    
    Application.ScreenUpdating = False
    For i = Cells.Find("*", , , , 1, 2).Row To 1 Step -1
        If LCase(Range(cMail & i).Value) = LCase(Range(cMail & i + 1).Value) Then
            Range(cPhone & i).Value = Range(cPhone & i + 1).Value
            Rows(i + 1).Delete
        End If
    Next
    Application.ScreenUpdating = True
    
End Sub

**protonLeah** · 07-08-2013, 10:50 PM

Option Explicit
Sub test()
    Application.ScreenUpdating = False
    
    Dim LastRow     As Long, _
        TestRow     As Long, _
        NextColumn  As Long, _
        AnchorRow   As Long, _
        MaxCol      As Long, _
        BlankPos    As Long, _
        Phone       As String, _
        Contact     As String, _
        NextContact As String, _
        SortRange   As Range
    
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For AnchorRow = 1 To LastRow
        Contact = Cells(AnchorRow, "a").Value
        BlankPos = InStr(Contact, " ")
        Cells(AnchorRow, "B").Value = Right(Contact, Len(Contact) - BlankPos)
        Contact = Left(Contact, BlankPos - 1)
        Cells(AnchorRow, "A").Value = Contact
        
        NextColumn = 2
        TestRow = AnchorRow + 1
        NextContact = Left(Cells(TestRow, "a").Value, Len(Cells(TestRow, "a").Value) - 9)
        
        While NextContact = Contact
            NextColumn = NextColumn + 1
            Cells(AnchorRow, NextColumn).Value = Right(Cells(TestRow, "A").Value, 8)
            Cells(TestRow, 1).Value = ""
            TestRow = TestRow + 1
            If TestRow > LastRow Then
                Set SortRange = Range(Cells(1, 1), Cells(LastRow, MaxCol))
                SortRange.Select
                ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add _
                    Key:=Range("A1"), _
                    SortOn:=xlSortOnValues, _
                    Order:=xlAscending, _
                    DataOption:=xlSortNormal
                With ActiveWorkbook.Worksheets("Sheet1").Sort
                    .SetRange SortRange
                    .Header = xlGuess
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
                Range("A1").Select
                Exit Sub
            End If
            NextContact = Left(Cells(TestRow, "a").Value, Len(Cells(TestRow, "a").Value) - 9)
        Wend
            
        AnchorRow = TestRow - 1
        MaxCol = WorksheetFunction.Max(NextColumn, MaxCol)
    Next AnchorRow
    Application.ScreenUpdating = True
End Sub

Or...

Sub Last_Pnone_Number()
    
    Const cMail As String = "A"     'Conlumn letter with the email data
    Const cPhone As String = "B"    'Column letter with the phone numbers
    Dim i           As Long, _
        BlankPos    As Long

    Application.ScreenUpdating = False
    For i = Cells.Find("*", , , , 1, 2).Row To 1 Step -1
        BlankPos = InStr(Range(cMail & i).Value, " ")
        If LCase(Left(Range(cMail & i).Value, BlankPos)) = LCase(Left(Range(cMail & i + 1).Value, BlankPos)) Then
            Range(cPhone & i).Value = Range(cMail & i + 1).Value
            Rows(i + 1).Delete
        End If
    Next
    Application.ScreenUpdating = True
    
End Sub