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):
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]First Name[/TD]
[TD]Last Name[/TD]
[TD]Address[/TD]
[TD]City[/TD]
[TD]State[/TD]
[TD]ZIP[/TD]
[/TR]
[TR]
[TD]Alex[/TD]
[TD]Johnson[/TD]
[TD]123 Broadway St[/TD]
[TD]Santa Clara[/TD]
[TD]IL[/TD]
[TD]54687[/TD]
[/TR]
[TR]
[TD]Leah[/TD]
[TD]Johnson[/TD]
[TD]123 Broadway St[/TD]
[TD]Santa Clara[/TD]
[TD]IL[/TD]
[TD]54687[/TD]
[/TR]
[TR]
[TD]Jason[/TD]
[TD]Mendoza[/TD]
[TD]765 State St[/TD]
[TD]Dorson[/TD]
[TD]MS[/TD]
[TD]87456[/TD]
[/TR]
</tbody>[/TABLE]

Desired Result (Sheet 2):
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Names[/TD]
[TD]Address[/TD]
[TD]City[/TD]
[TD]State[/TD]
[TD]ZIP[/TD]
[/TR]
[TR]
[TD]Alex & Leah Johnson[/TD]
[TD]123 Broadway St[/TD]
[TD]Santa Clara[/TD]
[TD]IL[/TD]
[TD]54687[/TD]
[/TR]
[TR]
[TD]Jason Mendoza[/TD]
[TD]765 State St[/TD]
[TD]Dorson[/TD]
[TD]MS[/TD]
[TD]87456[/TD]
[/TR]
</tbody>[/TABLE]


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