Modify code to transpose a stack of data to rows on to delimit on text hone number field

Hello,

I have single stack column that I need to turn in to a group of rows. However, number of rows that make up each group is variable but each group ends with an phone number field.

So I want to move the data over one column from the previous moved column including the phone number. After the phone number field is placed, I want the loop the begin with the name field in the first column and transpose the next group of data. I understand the the data will not be formatted correctly but I can fix that later.

I have code for delimiting on blank spaces:


Example of data in SOD (i.e. Civ):
Name
Address
Address1
Blah
Blah
(555)555-5555
Name
Address
(555)555-5555
Name
Address
Address1
Blah
(555)555-5555


Finish product will be:
Name Address Address1 Blah Blah (555)555-5555
Name Address (555)555-5555
Name Address Address1 Blah (555)555-5555


I found code here (thank you, watersev!) for delimiting on blanks. How do I modify it to find for my phone number field that is formatted as a text field?

Code to delimit on blanks below:

Sub test()

Dim myrange As Range, x

Application.ScreenUpdating = 0

On Error Resume Next
Set myrange = Range("a1", Cells(Rows.Count, 1).End(xlUp))

With myrange
   
    .SpecialCells(xlCellTypeBlanks) = "$"
    x = Split("|" & Join(Application.Transpose(myrange), "|"), "$")
    With Range("d1").Resize(UBound(x) + 1)
        .Value = Application.Transpose(x)
        .TextToColumns DataType:=xlDelimited, other:=True, otherchar:="|"
    End With
    .Replace "$", "", xlWhole
End With

Application.ScreenUpdating = 1

End Sub

Try this,

Sub AStuff()
'davesexcel
    Application.ScreenUpdating = False

    Dim lastrow As Long, r As Long
    Dim RangeArea As Range

    lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    For r = lastrow To 2 Step -1

        If Cells(r, 1).Value = "Name" Then Rows(r).Insert

    Next r

    For Each RangeArea In Columns("A").SpecialCells(xlCellTypeConstants, 23).Areas

        RangeArea.Copy
        Cells(Rows.Count, "D").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                                                False, Transpose:=True
    Next RangeArea
    Application.CutCopyMode = False

End Sub