VBA split string of text into multiple rows

[FryGirl]

In column A, I have a list of tasks. Some rows have multiple tasks which need to be broken out into their own rows. In the example below, there are 3 rows. Row 2 has 6 tasks in the one line. It should actually be 8 rows.

If there was only two tasks in one row, I was able to do that with the following macro, just not sure about with 3 or more.

Sub SplitRow()
    Dim i As Long
    Dim LastRow As Long: LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For i = LastRow To 2 Step -1
        Dim pos1 As Long: pos1 = InStr(1, Range("A" & i), " A4")
        If pos1 > 0 Then
            Rows(i + 1).Insert
            Cells(i + 1, 1).Value = Right(Cells(i, 1).Value, Len(Cells(i, 1)) - InStr(pos1, Cells(i, 1).Value, ""))
            Cells(i, 1).Value = Left(Cells(i, 1).Value, pos1)
        End If
    Next i
End Sub

Before
A4.25.1.7. MAINTAINS SPILL RESPONSE KIT.
A4.2.138. REPAIRS REGENERATIVE AIR SWEEPER ELECTRICAL COMPONENT. A4.2.139. ADJUSTS REGENERATIVE AIR SWEEPER HYDRAULIC COMPONENT. A4.2.140. ISOLATES REGENERATIVE AIR SWEEPER HYDRAULIC MALFUNCTION. A4.2.141. REPAIRS REGENERATIVE AIR SWEEPER HYDRAULIC COMPONENT. A4.2.142. ADJUSTS REGENERATIVE AIR SWEEPER MECHANICAL COMPONENT. A4.2.143. ISOLATES REGENERATIVE AIR SWEEPER MECHANICAL SYSTEM MALFUNCTION.
A4.25.1.4. ATTENDS VARIOUS ENVIRONMENTAL PROTECTION COMMITTEE MEETING AND DISSEMINATES INFORMATION.

After
A4.25.1.7. MAINTAINS SPILL RESPONSE KIT.
A4.2.138. REPAIRS REGENERATIVE AIR SWEEPER ELECTRICAL COMPONENT.
A4.2.139. ADJUSTS REGENERATIVE AIR SWEEPER HYDRAULIC COMPONENT.
A4.2.140. ISOLATES REGENERATIVE AIR SWEEPER HYDRAULIC MALFUNCTION.
A4.2.141. REPAIRS REGENERATIVE AIR SWEEPER HYDRAULIC COMPONENT.
A4.2.142. ADJUSTS REGENERATIVE AIR SWEEPER MECHANICAL COMPONENT.
A4.2.143. ISOLATES REGENERATIVE AIR SWEEPER MECHANICAL SYSTEM MALFUNCTION.
A4.25.1.4. ATTENDS VARIOUS ENVIRONMENTAL PROTECTION COMMITTEE MEETING AND DISSEMINATES INFORMATION.

 

[MPW]

This might not be exactly what you need, but it should point you in the right direction.

    For tx1 = 1 To Len(Cells(1, 1))
        i = Cells(Rows.Count, 1).End(xlUp).Row + 1
        If Mid(Cells(1, 1), tx1, 2) = "A4" Then
            For tx2 = tx1 + 1 To Len(Cells(1, 1))
                If Mid(Cells(1, 1), tx2, 2) = "A4" Then
                    Cells(i, 1) = Mid(Cells(1, 1), tx1, (tx2 - (tx1)))
                    tx1 = tx2 - 1
                    Exit For
                ElseIf tx2 = Len(Cells(1, 1)) Then
                    Cells(i, 1) = Right(Cells(1, 1), Len(Cells(1, 1)) - (tx1))
                End If
            Next tx2
        End If
    Next tx1

I pasted your text into Cells(1, 1) and this broke it out into separate lines.

 

[kweaver]

Try this (I'm sure someone will have a much slicker approach, but I think this works):

Sub SplitRow()
    Dim i As Long, j As Long, k As Long, txtstr() As String
    Dim LastRow As Long: LastRow = Range("A" & Rows.Count).End(xlUp).Row
    k = 1
    For i = 1 To LastRow
       txtstr = Split(Range("A" & i), "A4")
       j = UBound(txtstr)
       For jj = 1 To j
         Range("B" & k) = "A4" & txtstr(jj)
         k = k + 1
       Next jj
    Next i
End Sub

 

[MPW]

both of these are weak because they depend on the "A4", but I did not see another way. I like your code kweaver. Did not see how it traps the last "A4" item.

 

[FryGirl]

Thanks to both of you.

kweaver, yours does the trick.

 

[kweaver]

both of these are weak because they depend on the "A4", but I did not see another way. I like your code kweaver. Did not see how it traps the last "A4" item.

MPW: the split function finds all of them.

 

[MPW]

Kweaver: nice, I will take a closer look at that approach next time.