Excel - VBA function to dissolve text string

Some selective splitting might work!

Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and then scroll down to Manage Attachments to open the upload window.

the data is too erratic in structure to use either formulas or VBA with any degree of accuracy for the output. The data would need to be a bit more organized with unique characters to separate the city grouping. Then it might be feasible to use something like a Split function to to produce the desired output. Unforutunately, the computer cannot think and has to be directed as to what it looks for logically. However, some might give it a try.

If you'll post a sample, I'm willing to try it

You're welcome and thanks for the rep!

Try this:

Sub Grupper(): Dim Brb As String, Z, r As Long, Cty As String, n As Long, i As Long
                    r = 3: Do Until Cells(r, 2) = "": n = 1
 Brb = Replace(Cells(r, 2), ",", ""): Z = Split(Brb): Brb = Z(0): i = 0
                    Rows(r).Delete: r = r - 1
                    Do Until n = UBound(Z)
                    If IsNumeric(Left(Z(n), 1)) Then
                    i = 1: r = r + 1: Rows(r).Insert
        Cells(r, 2) = Brb & " " & Z(n) & ", " & Z(UBound(Z))
                    Else: Brb = IIf(i, Z(n), Brb & " " & Z(n)): i = 0
                    End If
                    n = n + 1: Loop: r = r + 1: Loop
End Sub

Hi Grupper,

If the Queue would only be 10 or less times longer then this version will run rather quickly:

Sub GrupperQ(): Dim Brb As String, Z, r As Long, s As Long, n As Long, i As Long, P, Q
            r = Range("B:B").Find("*", , , , xlByRows, xlPrevious).Row
    P = Cells(1, 2).Resize(r, 1): Q = Cells(1, 2).Resize(10 * UBound(P, 1), 1)

          s = 3:    For r = 3 To UBound(P): n = 1
 Brb = Replace(P(r, 1), ",", ""): Z = Split(Brb): Brb = Z(0): i = 0
                    Do Until n = UBound(Z)
                    If IsNumeric(Left(Z(n), 1)) Then
        i = 1: Q(s, 1) = Brb & " " & Z(n) & ", " & Z(UBound(Z)): s = s + 1
                    Else: Brb = IIf(i, Z(n), Brb & " " & Z(n)): i = 0
                    End If
                    n = n + 1: Loop: Next r
                    Cells(1, 2).Resize(s, 1) = Q
End Sub