Excel subroutine, transpose values delimited by comma to rows

Question

I have a problem, at work I was asked to take a data set and make some modifications. The problem is that there is one field which contains values 1,2,3,4-10,13-17,20 , and I have to expand the multiple ranges in the cell, transpose the figures into rows, and copy the rest of the row with it.

Example:

FIELD1 FIEL2 FIELD3 FIELD4
test1  test2 test3  1,2,3,4-10

should become:

FIELD1 FIEL2 FIELD3 FIELD4
test1  test2 test3  1
test1  test2 test3  2
test1  test2 test3  3
test1  test2 test3  4
test1  test2 test3  5
test1  test2 test3  6

and repeat the same for all the remaining rows until it will find an empty cell.

Below you can see my Frankenstein Subroutine which I have part developed, part stitched together from other sources. Problem is, this does partially work, but it doesn't do the job properly with more than one row. You can try:

Select the first cell and run the routine from a button
1,2,3
4,5,6

Any Help? Thanks in advance.

Sub Ops()

    'DECLARE VARIABLES
    Dim i As Long, st As String
    i = 1
    Dim startP As Range
    Dim c As Collection
    Dim count As Integer
    Set c = New Collection
    ary = Split(ActiveCell.Value, ",")

    Do Until IsEmpty(ActiveCell.Value)
        count = 0

        For Each r In Selection
            If i = 1 Then
                st = r.Text
                i = 1
            Else
                st = st & "," & r.Text
            End If
        Next r

        Set startP = Selection(1, 2)
        ary = Split(st, ",")
        i = 1

        For Each a In ary
            count = count + 1
            startP(i, 1).Value = a
            i = i + 1
        Next a

        'COUNT MINUS 1
        scount = count - 1

        'REPEAT UNTIL REACH COUNT
        For ba = 1 To scount
            'COPY AND INSERT ROWS BELOW
            ActiveCell.Copy
            Selection.Insert Shift:=xlDown
        Next ba

        Selection.Offset(count, 1).Select

        'ONCE THE LOOP IS FINISH GO TO NEXT CELL
        Selection.Offset(0, -1).Select

    Loop

End Sub

You can see the data below

In the Postcode cell, I need to expand the multiple ranges, and copy and insert below the same row Xtimes the number of postcodes in the cell.

Answer 1

This code does what you require - please be aware I have no well-defined cell referencing, since we're basing it on ActiveCell, I've left Ranges as Range rather than worksheet.Range

Sub x()
Do While ActiveCell.Value2 <> ""
    If InStr(1, ActiveCell.Value2, ",") > 0 Or InStr(1, ActiveCell.Value2, "-") > 0 Then e
    ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub e()

Dim a As Long
Dim r As Long
Dim c As Long
Dim rc As Long
Dim i As Long
Dim j As Long
Dim x() As String
Dim t() As String

    x = Split(ActiveCell, ",")
    r = ActiveCell.Row
    c = ActiveCell.Column


    For i = LBound(x) To UBound(x)
        If InStr(1, x(i), "-") Then
            a = a + Split(x(i), "-")(1) - Split(x(i), "-")(0)
        End If
    Next i

    a = a + UBound(x)
    Range(Cells(r + 1, c), Cells(r + a, c)).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    For i = LBound(x) To UBound(x)
        t = Split(x(i), "-")
        If UBound(t) = 0 Then
            Cells(r + rc, c).Value2 = t(0)
            rc = rc + 1
        Else
            For j = t(0) To t(1)
                Cells(r + rc, c).Value2 = j
                rc = rc + 1
            Next j
        End If
    Next i

    Range(Cells(r, c - 3), Cells(r + rc - 1, c - 1)).Value2 = _
        Range(Cells(r, c - 3), Cells(r, c - 1)).Value2

End Sub

This basically fills that column one by one based on the numbers x,y,ab,z by splitting first on , and then on any instances of -

After that, it's already got the row counter rc so just uses that counter to flood the range top to bottom, duplicating values in the 3 columns before the active cell

EDIT: I added 5 lines which actually goes through the ranges (1,2,4-7 whatever) to count how many rows to INSERT before actually filling in the information.

EDIT2: I added another sub routine called x to make this e routine loop until it reaches a cell with nothing in it... So to get the whole sheet fixed up, just highlight the uppermost cell with a range like (1,3,4-7... etc) and run the x routine