Split cell into multiple rows?


I have a "messy" spreadsheet I'm trying to reconfigure for analysis. There are 450 rows, but here's a sample of two:

1Test ASalaries/Benefits: $10,001.01
Purchased Services: $22.99
Supplies/Materials: $500.23
Capital Objects: $7,216.25
2Test BSalaries/Benefits: $3,518.62
Purchased Services: $618.72

With those amounts in the same cell it isn't helpful for doing large reports quickly. Ideally, I'd break it down to match this:

IDNameType Amount 
1Test ASalaries/Benefits:    10,001.01
1Test APurchased Services:            22.99
1Test ASupplies/Materials:          500.23
1Test ACapital Objects:      7,216.25
2Test BSalaries/Benefits:      3,518.62
2Test BPurchased Services:          618.72

I'm assuming this is going to be a multi-step process. I started off trying to use the text-to-columns function on that notes column in the first table, but it only recognized the first amount and deleted everything after that. Currently I'm trying to find some combination of the find and substitute functions that will work.


Has anyone else been able to solve a similar problem, or at least an idea of how to solve this? If I were to do this by hand it would take weeks, as I have more spreadsheets like this coming

1 Reply


You could run this macro:

Sub SplitCells()
    Dim r As Long
    Dim m As Long
    Dim c() As String
    Dim p() As String
    Dim i As Long
    Application.ScreenUpdating = False
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = m To 2 Step -1
        c = Split(Range("C" & r).Value, vbLf)
        If UBound(c) > 0 Then
            For i = UBound(c) To 1 Step -1
                Range("A" & r + 1).EntireRow.Insert
                Range("A" & r + 1).Value = Range("A" & r).Value
                Range("B" & r + 1).Value = Range("B" & r).Value
                p = Split(c(i), ": $")
                Range("C" & r + 1).Value = p(0)
                Range("D" & r + 1).Value = p(1)
            Next i
            p = Split(c(0), ": $")
            Range("C" & r).Value = p(0)
            Range("D" & r).Value = p(1)
        End If
    Next r
    Application.ScreenUpdating = True
End Sub