Excel: Duplicate Merging - excel

Question

So I've got an incredibly large contact list, originally an export from Outlook so it follows the same formatting. I've an incredibly large number of duplicates down to records holding the same name, but separate addresses / mobile numbers.
I'm looking for a macro that can help me merge these duplicates so I don't lose things like different addresses under the same name.
http://i.stack.imgur.com/EaI6e.png
In this case I'd love a macro to see that A3 is a duplicate of A2, so take J3 to O3 and paste these in Q2 to V2. Then repeat this process for any duplicate pair found.

Answer 1

This is a bit rudimentary, but it works. Note, since you didn't say what should happen where there are more than 2 duplicates, this macro won't really work if that's the case.
Sub moveDuplicates()
Dim i As Integer, lastRow As Integer
Dim primaryRange As Range, copyToRange As Range, cel As Range, cel2 As Range, rng As Range
Dim ws As Worksheet
Set ws = ActiveSheet
'First, sort by "Key" to get duplicates all in a row
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=Range( _
"A2:A" & ws.UsedRange.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.SetRange Range("A1:P" & ws.UsedRange.Rows.Count)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lastRow = ws.UsedRange.Rows.Count
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, 1))
Dim lastDupRow As Integer, startDupRow As Integer, copyRow As Integer
For Each cel In rng
'First, see if the cell has a duplicate anywhere, if not, then goto next cel
cel.Select
If WorksheetFunction.CountIf(rng, cel.Value) > 1 Then
Debug.Print "Duplicate exists"
'So, since we know a duplicate exists, we need to copy the duplicate rows' info.
startDupRow = cel.Row + 1
lastDupRow = ws.Columns(1).Find(cel.Value, searchDirection:=xlPrevious).Row
If lastDupRow - startDupRow = 0 Then
copyRow = lastDupRow
Else
End If
For Each cel2 In ws.Range(Cells(startDupRow, 1), ws.Cells(lastDupRow, 1))
' pasteRange(cel.Row).Select
' copyRange(cel2.Row).Select
pasteRange(cel.Row).Value = copyRange(cel2.Row).Value
copyRange(cel2.Row).EntireRow.Delete
Next cel2
End If
Next cel
End Sub
Private Function copyRange(ByVal iRow As Integer) As Range
Set copyRange = Range(Cells(iRow, 10), Cells(iRow, 15))
End Function
Private Function pasteRange(ByVal xRow As Integer) As Range
Set pasteRange = Range(Cells(xRow, 17), Cells(xRow, 22))
End Function