Macro to Summarize Address Data

Alex0013

Board Regular
Joined
Jul 23, 2014
Messages
154
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 NameLast NameAddressCityStateZIP
AlexJohnson123 Broadway StSanta ClaraIL54687
LeahJohnson123 Broadway StSanta ClaraIL54687
JasonMendoza765 State StDorsonMS87456

<tbody>
</tbody>

Desired Result (Sheet 2):
NamesAddressCityStateZIP
Alex & Leah Johnson123 Broadway StSanta ClaraIL54687
Jason Mendoza765 State StDorsonMS87456

<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)
 

Some videos you may like

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

PCL

Well-known Member
Joined
Jul 15, 2008
Messages
1,348
See next code
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

Well-known Member
Joined
Feb 7, 2012
Messages
11,936
Office Version
2013
Platform
Windows
Old fashioned way

Code:
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

Board Regular
Joined
Jul 23, 2014
Messages
154
Thank you both so much for your quick and accurate responses! Both worked perfectly in different ways!
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,758
Office Version
365, 2019, 2016
Platform
Windows
Power Query solution for kicks.

Code:
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

Well-known Member
Joined
Feb 7, 2012
Messages
11,936
Office Version
2013
Platform
Windows
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
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,099,787
Messages
5,470,778
Members
406,720
Latest member
tylergaps

This Week's Hot Topics

Top