Merge Rows of duplicates??

[anixan]

Hi,

I am trying to merge rows of duplicate entries, say I have the following information in a excel spreadsheet:

Column A: Name
Column B: First Line of Address
Column C: Area
Column D: County
Column E: Post Code
Column F: Tel Number

A|B|C|D|E|F
Dave | Rice Rd | Liverpool | Merseyside | L45 7HT | 6381754
Tony | Hill Grove | Runcorn | Merseyside | L78 9JU | 6527897
Mark | Rice Rd | Liverpool | Merseyside | L45 7HT | 6381754
John | Lime Ave | Runcorn | Merseyside | L34 9HF | 7248853


If I have the data above in my spreadsheet I want to basically search and look at columns B,C,D,E and F and then if there are any duplicates of these for that row anywhere on the sheet I want it to merge the Data for those duplicate as shown below:

A|B|C|D|E|F
Dave, Mark | Rice Rd | Liverpool | Merseyside | L45 7HT | 6381754
Tony | Hill Grove | Runcorn | Merseyside | L78 9JU | 6527897
John | Lime Ave | Runcorn | Merseyside | L34 9HF | 7248853

I have managed to find a macro that is shown below however this macro only looks at 1 column and then merges the data based on that which is not what I want. Usually I would just create this myself if it where in any other language however I cant seem to get this to work and would really appreciate the help.

Sub kTest()
Dim a, i As Long, w(), c As Long, z
With Range("a1")
    a = .CurrentRegion
    With CreateObject("scripting.dictionary")
        .comparemode = vbTextCompare
        For i = 2 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                If Not .exists(a(i, 1)) Then
                    ReDim w(1 To UBound(a, 2))
                    For c = 1 To UBound(a, 2): w(c) = a(i, c): Next
                    .Add a(i, 1), w
                Else
                    w = .Item(a(i, 1)): w(1) = a(i, 1)
                    For c = 2 To UBound(a, 2)
                        w(c) = .Item(a(i, 1))(c) & Chr(10) & a(i, c)
                    Next
                    .Item(a(i, 1)) = w
                End If
            End If
        Next
        z = .items
    End With
    .CurrentRegion.Offset(1).ClearContents
    For i = 0 To UBound(z)
        .Offset(i + 1).Resize(, UBound(z(i))).Value = z(i)
    Next
End With
End Sub

Thanks