Macro to re-format source data for physical address list

[lhnorth]

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
	A	B	C	D	E	F	G	H	I	J	K	L
1	↓↓↓This layout in green is what I need to have generated from the source example given in orange below↓↓↓
2	N Hill Rd. Anytown, PA 90210
3	Last Name	First Name	House Number	Apartment Number	Phone Number
4	Smith	Katherine	100	1	Not Available
5	Grover	David	102		(123) 456-7890
6	Dunn	Shelby	104		Not Available
7
8	Carver St. Anytown, PA 90210
9	Last Name	First Name	House Number	Apartment Number	Phone Number
10	Browser	Carl	202		(123) 867-5309
11	Karter	Mario	204	3	Not Available
12	Glibb	Phil	206		Not Available
13
14	↓↓↓Below this orange line is the source export layout that I need to auto-format as above↓↓↓
15	Last Name	First Name	House Number	Pre-directional	Street	Street Suffix	Post-directional	Apartment Number	City	State	Zip Code	Phone Number
16	Smith	Katherine	100	N	Hill	Rd.		1	Anytown	PA	90210	Not Available
17	Grover	David	102	N	Hill	Rd.			Anytown	PA	90210	(123) 456-7890
18	Dunn	Shelby	104	N	Hill	Rd.			Anytown	PA	90210	Not Available
19	Browser	Carl	202		Carver	St			Anytown	PA	90210	(123) 867-5309
20	Karter	Mario	204		Carver	St		3	Anytown	PA	90210	Not Available
21	Glibb	Phil	206		Carver	St			Anytown	PA	90210	Not Available
Sheet1

 

[kweaver]

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]

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"

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

 

[Peter_SSs]

in the future it would help if you used XL2BB to post the example(s)

In defence of the OP, surely that is XL2BB that has been used?

 

[kweaver]

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]

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.

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

 

[lhnorth]

I have taken exactly the same details as these & come up with this 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]

Did you try the code I submitted...

 

[lhnorth]

Did you try the code I submitted...

I did- just found a mislabeled tab- too little coffee before excel-. This works really well thank you!

 

[lhnorth]

I have taken exactly the same details as these & come up with this 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!