Macro to Summarize Address Data

[Alex0013]

Hello,

I'm looking for help in creating a macro to summarize a member database by Address. This is to get our mailing address list from our member database.

Any help on how I can accomplish this would be greatly appreciated!

Example Data (Sheet 1):

First Name	Last Name	Address	City	State	ZIP
Alex	Johnson	123 Broadway St	Santa Clara	IL	54687
Leah	Johnson	123 Broadway St	Santa Clara	IL	54687
Jason	Mendoza	765 State St	Dorson	MS	87456

<tbody>
</tbody>

Desired Result (Sheet 2):

Names	Address	City	State	ZIP
Alex & Leah Johnson	123 Broadway St	Santa Clara	IL	54687
Jason Mendoza	765 State St	Dorson	MS	87456

<tbody>
</tbody>

Basically, I want the names concatenated, and duplicates removed on unique combination of Address+City+State+ZIP

Anyone have any ideas on how I might be able to achieve this?

Thanks!
Alex
(Office 365 Version 1902, Windows 10)

 

[PCL]

See next code

Option Explicit
Sub Treat()
Dim ObjDic   As Object
Set ObjDic = CreateObject("Scripting.Dictionary")
Dim DelRg  As Range
Dim I  As Integer, LR  As Integer
Dim WkK, WkI
    LR = Cells(Rows.Count, 1).End(3).Row
    Set DelRg = Cells(LR + 1, 1)
    For I = 2 To LR
        WkK = Cells(I, 2) & Cells(I, 3) & Cells(I, 4) & Cells(I, 5)
        If (ObjDic.exists(WkK)) Then
            Set DelRg = Union(DelRg, Cells(I, 1))
            WkI = ObjDic.Item(WkK)
            Cells(WkI, 1) = Cells(WkI, 1) & " & " & Cells(I, 1)
        Else
            ObjDic(WkK) = I
        End If
    Next I
    DelRg.EntireRow.Delete
End Sub

 

[JLGWhiz]

Old fashioned way

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, lr As Long, fn As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
    With sh1
        .Range("C1:C" & lr).AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
        For Each c In .Cells(lr + 2, 1).CurrentRegion.Offset(1)
            If c <> "" Then
                Set fn = .Range("C1:C" & lr).Find(c.Value, , xlValues)
                    If Not fn Is Nothing Then
                        If fn.Value = fn.Offset(1).Value And fn.Offset(, 3).Value = fn.Offset(1, 3).Value And _
                        fn.Offset(, -1).Value = fn.Offset(1, -1).Value Then
                            sh2.Cells(Rows.Count, 1).End(xlUp)(2) = _
                            fn.Offset(, -2).Value & " ""&"" " & fn.Offset(1, -2).Value
                            sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1).Resize(, 5) = _
                            fn.Offset(, -1).Resize(, 5).Value
                        ElseIf fn.Value = fn.Offset(1).Value And fn.Offset(, 3).Value = fn.Offset(1, 3).Value And _
                        fn.Offset(, 1).Value <> fn.Offset(1, -1).Value Then
                            sh2.Cells(Rows.Count, 1).End(xlUp)(2) = _
                            fn.Offset(, -2).Value & vbLf & fn.Offset(1, -2).Value
                            sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = _
                            fn.Offset(, -1).Value & vbLf & fn.Offset(1, -1).Value
                            sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 2).Resize(, 4) = _
                            fn.Resize(, 4).Value
                        Else
                            sh2.Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 6) = fn.Offset(, -2).Resize(, 6).Value
                        End If
                    End If
            End If
        Next
        .Cells(lr + 2, 1).CurrentRegion.ClearContents
    End With
End Sub

 

[Alex0013]

Thank you both so much for your quick and accurate responses! Both worked perfectly in different ways!

 

[lrobbo314]

Power Query solution for kicks.

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Group = Table.Group(Source, {"Last Name"}, {{"Count", each _, type table}}),
    FNCombo = Table.AddColumn(Group, "Custom", each Text.Combine(Table.Column([Count],"First Name"), " & ") & " " & [Last Name]),
    Remove = Table.RemoveColumns(FNCombo,{"Last Name"}),
    Reorder = Table.ReorderColumns(Remove,{"Custom", "Count"}),
    Expand = Table.ExpandTableColumn(Reorder, "Count", {"Address", "City", "State", "ZIP"}, {"Address", "City", "State", "ZIP"}),
    NoDupes = Table.Distinct(Expand, {"Custom"}),
    Rename = Table.RenameColumns(NoDupes,{{"Custom", "Names"}})
in
    Rename

 

[JLGWhiz]

Thank you both so much for your quick and accurate responses! Both worked perfectly in different ways!

You're welcome and thanks for the feedback,
Regards, JLG