Macro to re-format source data for physical address list

lhnorth

New Member
Joined
Aug 18, 2015
Messages
11
Please see the below. Any help is greatly appreciated! In orange is a sample of what the address list looks like pulled from our master file. I need a macro (or something), than can run on a file like this and generate the sample format / layout in green, which is currently being created manually with a lot of moving cells, etc., as you can imagine.
Format Help 5.7.22.xlsx
ABCDEFGHIJKL
1↓↓↓This layout in green is what I need to have generated from the source example given in orange below↓↓↓
2N Hill Rd. Anytown, PA 90210
3Last NameFirst NameHouse NumberApartment NumberPhone Number
4SmithKatherine1001Not Available
5GroverDavid102(123) 456-7890
6DunnShelby104Not Available
7
8Carver St. Anytown, PA 90210
9Last NameFirst NameHouse NumberApartment NumberPhone Number
10BrowserCarl202(123) 867-5309
11KarterMario2043Not Available
12GlibbPhil206Not Available
13
14↓↓↓Below this orange line is the source export layout that I need to auto-format as above↓↓↓
15Last NameFirst NameHouse NumberPre-directionalStreetStreet SuffixPost-directionalApartment NumberCityStateZip CodePhone Number
16SmithKatherine100NHillRd.1AnytownPA90210Not Available
17GroverDavid102NHillRd.AnytownPA90210(123) 456-7890
18DunnShelby104NHillRd.AnytownPA90210Not Available
19BrowserCarl202CarverStAnytownPA90210(123) 867-5309
20KarterMario204CarverSt3AnytownPA90210Not Available
21GlibbPhil206CarverStAnytownPA90210Not Available
Sheet1
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

kweaver

Well-known Member
Joined
May 8, 2018
Messages
2,470
Office Version
  1. 365
  2. 2010
What's the "key" to this? The address (house & Pre-directional & Street & Street Suffix etc. ???

in the future it would help if you used XL2BB to post the example(s)
It would also help if you changes your account information to indicate which version of Excel you are using.
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
3,165
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Does this do what you want...
This code will take the source data which I moved to "Sheet2", starting in Cell A1 and write your re-formatted data to "Sheet1", also starting at Cell A1. I did not do any of the bold formatting. This tested with your data as shown, except that the data was put on "Sheet2"

VBA Code:
Sub FormatText()
    
    Dim ws1 As Worksheet: Set ws1 = Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim arr, arr2, fin, hdr, ord
    Dim i As Long, e As Long, lRow As Long, r As Long
    Dim col As Long, nl As Long, rw As Integer
    
    Application.ScreenUpdating = False
    hdr = Array("Last Name", "First Name", "House Number", "Apartment Number", "Phone Number")
    ord = Array(1, 2, 3, 8, 12)
    rw = 1: col = 1
    
    With ws2
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        ReDim arr2(1 To lRow - 1, 1 To 1)
        arr = .Range("A2:M" & lRow)
        For i = 1 To UBound(arr)
            For e = 4 To 11
                If e <> 8 And e <> 9 Then arr(i, 13) = arr(i, 13) & " " & arr(i, e)
                If e = 9 Then arr(i, 13) = arr(i, 13) & " " & arr(i, e) & ","
            Next
             arr(i, 13) = Trim(arr(i, 13))
             arr2(i, 1) = arr(i, 13)
        Next
    End With
    
    With CreateObject("scripting.dictionary")
        For r = 1 To UBound(arr2)
            If Not IsMissing(arr(r, 1)) Then .Item(arr2(r, 1)) = 1
        Next
        fin = .keys
    End With
    
    For i = 0 To UBound(fin)
        ws1.Range("A" & rw) = fin(i)
        rw = rw + 1
        ws1.Range("A" & rw & ":E" & rw) = hdr
        rw = rw + 1
        For r = 1 To UBound(arr)
            If arr(r, 13) = fin(i) Then
                For nl = 0 To 4
                    ws1.Cells(rw, col) = arr(r, ord(nl))
                    col = col + 1
                Next
                col = 1
                rw = rw + 1
            End If
        Next
    rw = rw + 1
    Next
    Application.ScreenUpdating = True
    
End Sub
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
2,470
Office Version
  1. 365
  2. 2010
:confused: In defence of the OP, surely that is XL2BB that has been used?
Groan, you are correct. It was too late to change my comment after I selected the data and realized it.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
56,546
Office Version
  1. 365
Platform
  1. Windows
This code will take the source data which I moved to "Sheet2", starting in Cell A1 and write your re-formatted data to "Sheet1", also starting at Cell A1. I did not do any of the bold formatting.
I have taken exactly the same details as these & come up with this code.

VBA Code:
Sub Rearrange()
  Dim d As Object
  Dim a As Variant, b As Variant, ky As Variant, rw As Variant, Hdrs As Variant, Data As Variant
  Dim i As Long, j As Long, k As Long
  Dim s As String
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  a = Sheets("Sheet2").Range("A1").CurrentRegion.Value
  Hdrs = Split("Last Name|First Name|House Number|Apartment Number|Phone Number", "|")
  With Application
    For i = 2 To UBound(a)
      s = .Trim(Join(.Index(a, i, Array(4, 5, 6, 7, 9))) & ", " & Join(.Index(a, i, Array(10, 11))))
      d(s) = d(s) & " " & i
    Next i

    ReDim b(1 To UBound(a) + d.Count * 3, 1 To 5)
    For Each ky In d.keys()
      k = k + 1
      b(k, 1) = ky
      k = k + 1
      For j = 1 To 5
        b(k, j) = Hdrs(j - 1)
      Next j
      For Each rw In Split(Mid(d(ky), 2))
        k = k + 1
        Data = .Index(a, rw, Array(1, 2, 3, 8, 12))
        For j = 1 To 5
          b(k, j) = Data(j)
        Next j
      Next rw
      k = k + 1
    Next ky
  End With
  Sheets("Sheet1").Range("A1").Resize(k - 1, 5).Value = b
End Sub
 
Solution

lhnorth

New Member
Joined
Aug 18, 2015
Messages
11
I have taken exactly the same details as these & come up with this code.

VBA Code:
Sub Rearrange()
  Dim d As Object
  Dim a As Variant, b As Variant, ky As Variant, rw As Variant, Hdrs As Variant, Data As Variant
  Dim i As Long, j As Long, k As Long
  Dim s As String
 
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  a = Sheets("Sheet2").Range("A1").CurrentRegion.Value
  Hdrs = Split("Last Name|First Name|House Number|Apartment Number|Phone Number", "|")
  With Application
    For i = 2 To UBound(a)
      s = .Trim(Join(.Index(a, i, Array(4, 5, 6, 7, 9))) & ", " & Join(.Index(a, i, Array(10, 11))))
      d(s) = d(s) & " " & i
    Next i

    ReDim b(1 To UBound(a) + d.Count * 3, 1 To 5)
    For Each ky In d.keys()
      k = k + 1
      b(k, 1) = ky
      k = k + 1
      For j = 1 To 5
        b(k, j) = Hdrs(j - 1)
      Next j
      For Each rw In Split(Mid(d(ky), 2))
        k = k + 1
        Data = .Index(a, rw, Array(1, 2, 3, 8, 12))
        For j = 1 To 5
          b(k, j) = Data(j)
        Next j
      Next rw
      k = k + 1
    Next ky
  End With
  Sheets("Sheet1").Range("A1").Resize(k - 1, 5).Value = b
End Sub
Thank you for this- as I'm applying this to the original data set I get the error in the uploaded image. I'm sure this is something I'm doing wrong as I've tried to apply this macro to the original file I pulled the example from. Any feedback is greatly appreciated!
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
3,165
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
Did you try the code I submitted...
 

lhnorth

New Member
Joined
Aug 18, 2015
Messages
11
I have taken exactly the same details as these & come up with this code.

VBA Code:
Sub Rearrange()
  Dim d As Object
  Dim a As Variant, b As Variant, ky As Variant, rw As Variant, Hdrs As Variant, Data As Variant
  Dim i As Long, j As Long, k As Long
  Dim s As String
 
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  a = Sheets("Sheet2").Range("A1").CurrentRegion.Value
  Hdrs = Split("Last Name|First Name|House Number|Apartment Number|Phone Number", "|")
  With Application
    For i = 2 To UBound(a)
      s = .Trim(Join(.Index(a, i, Array(4, 5, 6, 7, 9))) & ", " & Join(.Index(a, i, Array(10, 11))))
      d(s) = d(s) & " " & i
    Next i

    ReDim b(1 To UBound(a) + d.Count * 3, 1 To 5)
    For Each ky In d.keys()
      k = k + 1
      b(k, 1) = ky
      k = k + 1
      For j = 1 To 5
        b(k, j) = Hdrs(j - 1)
      Next j
      For Each rw In Split(Mid(d(ky), 2))
        k = k + 1
        Data = .Index(a, rw, Array(1, 2, 3, 8, 12))
        For j = 1 To 5
          b(k, j) = Data(j)
        Next j
      Next rw
      k = k + 1
    Next ky
  End With
  Sheets("Sheet1").Range("A1").Resize(k - 1, 5).Value = b
End Sub
This also works really well- thank you so much for the expertise!
 

Forum statistics

Threads
1,175,957
Messages
5,900,534
Members
434,835
Latest member
cmenconi

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top