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