De-duplicating, Merging and Totalling Exercise

Hi all,

I'm trying to de-duplicate a list of donors that have the same first name (column R below), surname (column S) AND postcode (column AA), whilst also merging data in the duplicates' other fields (unique email address and telephone number) and totalling their donation amount in column N. An example of the list is shown below:

Clipboard03.jpg

Note that non-relevant columns are hidden.

Specifically, I want to keep just the ID of the record that has had the data merged into it (with ID1 taking priority over ID2, ID2 over ID3, etc.). The RowID is for my reference so I can later view which rows have been removed as a result of the de-dupe.

Any help would be greatly appreciated.

Thanks

Thanks for the advice. A sample workbook can be found below with BEFORE and AFTER sheets. As before, the data has been desensitized.



Cheers

Thanks Mick,

Works perfectly.

I did, however, forget to include the donations data in column N, which I need to total for all the duplicates as in the updated example worksheet attached. Would it be possible to possible to add this function to the code?

Thanks

Try this:-

Sub MG28Feb00
Dim Rng             As Range
Dim Dn              As Range
Dim oTxt            As String
Dim cols            As Variant
Dim n               As Integer
With Sheets("BEFORE")
    Set Rng = .Range(.Range("R1"), .Range("R" & Rows.Count).End(xlUp))
End With
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For Each Dn In Rng
oTxt = Join(Application.Index(Dn.Resize(, 10).Value, 1, Array(1, 2, 3, 7, 10)))
    If Not .Exists(oTxt) Then
        .Add oTxt, Dn
    Else
        Set .Item(oTxt) = Union(.Item(oTxt), Dn)
    End If
Next

Dim k       As Variant
Dim R       As Range
Dim c       As Long
ReDim ray(1 To .Count, 1 To 27)
cols = Array(-17, -16, -15, -14, -13, -10, -5, -4, 0, 1, 2, 7, 9)

For Each k In .keys
    c = c + 1
    For Each R In .Item(k)
        For n = 0 To UBound(cols)
        If Not IsEmpty(R.Offset(, cols(n))) Then
            If cols(n) = "-4" Then
                ray(c, cols(n) + 18) = ray(c, cols(n) + 18) + R.Offset(, cols(n))
            Else
                If IsEmpty(ray(c, cols(n) + 18)) Then
                    ray(c, cols(n) + 18) = R.Offset(, cols(n))
                End If
            End If
        End If
    Next n
   Next R
Next k

End With
Sheets("AFTER").Range("A1").Resize(c, 27).Value = ray
MsgBox "Run"
End Sub

Regards Mick

Excellent, thanks so much, Mick