Excel: Expand multi-line rows

How to end up with one row per entry in a spreadsheet when some cells contain multiple entries. This example will expand the data below in to multiple rows using a VB. Noting here for my reference.

The following code with take the above (Sheet1) content and create a new worksheet (Sheet2) with the expanded records. As the code expands both column D & E an error is thrown for row 4 as the same number of entries do not match in both cells.

Public Sub expandData()
    MsgBox "Make sure to have an Empty Sheet2"
    If Not IsEmpty(Worksheets("Sheet2").Range("A1").Value) Then
        MsgBox "Sheet2 looks like it has data?"
    Else
        Dim i As Long
        Dim insertrow As Long
        
        i = 1
        insertrow = 1
        Do While Not IsEmpty(Worksheets("Sheet1").Range("A" + CStr(i)).Value)
            insertrow = expandRow2("A" + CStr(i) + ":C" + CStr(i), "D" + CStr(i), "E" + CStr(i), insertrow)
            i = i + 1
        Loop
    End If
End Sub


Private Function expandRow2(copyrange As String, expcell As String, expcell2 As String, insertpoint As Long)
    Dim count As Integer
    Dim sa() As String
    Dim sb() As String
    Dim i As Integer
    
    count = Worksheets("Sheet1").Range(copyrange).Columns.count
    sa() = Split(Worksheets("Sheet1").Range(expcell).Value, vbLf)
    sb() = Split(Worksheets("Sheet1").Range(expcell2).Value, vbLf)
    
    If UBound(sa) <> UBound(sb) Then
        Worksheets("Sheet1").Range(copyrange).Copy Destination:=Worksheets("Sheet2").Range("A" + CStr(insertpoint))
        Worksheets("Sheet2").Cells(insertpoint, count + 1).Value = "#ERROR"
        insertpoint = insertpoint + 1
    Else
        For i = 0 To UBound(sa)
            Worksheets("Sheet1").Range(copyrange).Copy Destination:=Worksheets("Sheet2").Range("A" + CStr(insertpoint))
            Worksheets("Sheet2").Cells(insertpoint, count + 1).Value = sa(i)
            Worksheets("Sheet2").Cells(insertpoint, count + 2).Value = sb(i)
            insertpoint = insertpoint + 1
        Next i
    End If
    expandRow2 = insertpoint
End Function
This entry was posted in Code, Microsoft, Software. Bookmark the permalink.

Leave a Reply

Your email address will not be published. Required fields are marked *