In an Excel file, extract separate lines of information in one cell as multiple rows

Question

I have an Excel file of records where one field is meant to track historical events. The file is unique by a specific Id, but this Id may have many events associated with it, up to 30 or 40. These events are listed as separate lines within one cell. There is no other delimiter other than a new line.

As you could imagine, this format makes extracting specific events difficult. I am curious if there is an Excel macro that I can use to extract all events as separate rows. So, for example, this is how the file appears now:

Id	Field A	Field B	Event
1	123	A	6/10/2024: Event A
			6/12/2024: Event B
			6/20/2024: Event C
2	456	B	6/6/2024: Event A
			6/7/2024: Event B

I would like the file to look like this:

Id	Field A	Field B	Event
1	123	A	6/10/2024: Event A
1	123	A	6/12/2024: Event B
1	123	A	6/20/2024: Event C
2	456	B	6/6/2024: Event A
2	456	B	6/7/2024: Event B

Note that in the first example, there are only two rows, while in the second example there are 5 rows

I tried using Text to Columns (selecting "Delimited" not "Fixed Width"), but I was not able to input a "new line" delimiter. It looks like I could only input a single character delimiter.

Am I able to use Text to Columns to achieve what I want? Or is there a macro that I can use? I am an Excel beginner but am interested in trying anything! Thank you!

Answer 1

I believe something like this should work for you:

Sub SplitIntoRows()
    
    Dim ws As Worksheet:    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim rData As Range:     Set rData = ws.Range("A2:D" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    Dim aData() As Variant: aData = rData.Value
    Dim lLastCol:           lLastCol = UBound(aData, 2)
    Dim aResults() As Variant:  ReDim aResults(1 To 10000, 1 To rData.Columns.Count)
    Dim iData As Long, jData As Long, iResult As Long
    
    Dim aSplit As Variant
    Dim vLine As Variant
    For iData = LBound(aData, 1) To UBound(aData, 1)
        aSplit = Split(aData(iData, lLastCol), Chr(10))
        For Each vLine In aSplit
            iResult = iResult + 1
            For jData = LBound(aData, 2) To UBound(aData, 2) - 1
                aResults(iResult, jData) = aData(iData, jData)
            Next jData
            aResults(iResult, lLastCol) = vLine
        Next vLine
    Next iData
    
    rData.Resize(iResult, UBound(aResults, 2)).Value = aResults
    
End Sub

Answer 2

In my comment I wrote <> when it should have been =. This is a quick test using your data:

Option Explicit

Sub pullDataToNextLineWhenBlank()
    With Sheets(1)
        Dim i As Long:  For i = 2 To .Cells(.Rows.Count, 4).End(xlUp).Row
            If Len(.Cells(i, 1).Value) = 0 Then .Cells(i, 1).Value = .Cells(i - 1, 1).Value
            If Len(.Cells(i, 2).Value) = 0 Then .Cells(i, 2).Value = .Cells(i - 1, 2).Value
            If Len(.Cells(i, 3).Value) = 0 Then .Cells(i, 3).Value = .Cells(i - 1, 3).Value
        Next i
    End With
End Sub

Before:

After:

If you know you will have columns 1, 2, and 3, always pulled together, you could do:

If Len(.Cells(i, 1).Value) = 0 Then .Range(.Cells(i, 1),.Cells(i,3)).Value = .Range(.Cells(i-1, 1),.Cells(i-1,3)).Value

Answer 3

If you have 365, you can do this with a formula in a single cell and the results will SPILL.

In the formula below,

• LOOKUP within MAKEARRAY is examining the entire table down to the row being examined (r), and returning the last non-blank entry in that row and column.
• I named the source table Table4, but you can use regular addressing if you prefer
  • you would repalce Table4[#Headers] with A1:D1
  • and Table4 in the d line with A2:D6

=VSTACK(
    Table4[#Headers],
    LET(
        d, Table4,
        a, MAKEARRAY(
            ROWS(d),
            COLUMNS(d),
            LAMBDA(r, c,
                LOOKUP(
                    2,
                    1 / LEN(INDEX(d, SEQUENCE(r), c)),
                    INDEX(d, SEQUENCE(r), c)
                )
            )
        ),
        a
    )
)

Answer 4

Transform Multi-Line to Single-Line Rows

Sub TransformToSingleLine()
    Const PROC_TITLE As String = "Transform to Single Line"

    ' Define constants.

    ' Source
    Const SRC_SHEET_NAME As String = "Sheet1"
    Const SRC_FIRST_HEADER_CELL_ADDRESS As String = "A1"
    Const SRC_MULTI_LINE_COLUMN As Long = 4
    Const SRC_MULTI_LINE_DELIMITER As String = vbLf ' could be 'vbCrLf'
    ' Destination
    Const DST_SHEET_NAME As String = "Sheet2"
    Const DST_FIRST_HEADER_CELL_ADDRESS As String = "A1"
    ' Other
    Const KEEP_BLANKS As Boolean = True
    Const DISPLAY_MESSAGES As Boolean = True
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read (source range to source array, source array to split array).
    
    ' Reference.
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    Dim scell As Range: Set scell = sws.Range(SRC_FIRST_HEADER_CELL_ADDRESS)
    Dim srg As Range:
    With scell.Cells(1).CurrentRegion
        Set srg = scell.Resize(.Row + .Rows.Count - scell.Row, _
            .Column + .Columns.Count - scell.Column)
    End With
    
    ' Check rows.
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < 2 Then
        If DISPLAY_MESSAGES Then
            MsgBox "No data found!", vbExclamation, PROC_TITLE
        End If
        Exit Sub
    End If
    
    ' Check columns.
    Dim cCount As Long: cCount = srg.Columns.Count
    If cCount < SRC_MULTI_LINE_COLUMN Then
        If DISPLAY_MESSAGES Then
            MsgBox "Not enough columns!", vbExclamation, PROC_TITLE
        End If
        Exit Sub
    End If
    
    ' Source values to array.
    Dim sData() As Variant: sData = srg.Value
    
    Dim Splits() As Variant: ReDim Splits(1 To srCount, 1 To 2)
    Dim drCount As Long: drCount = 1 ' skip headers
    Dim sr As Long
    ' 1st column will hold the 'split' arrays, 2nd column their upper limits.
    ' Most importantly, 'drCount' will hold the number of destination rows.
    For sr = 2 To srCount
        Splits(sr, 1) = Split(CStr(sData(sr, SRC_MULTI_LINE_COLUMN)), _
            SRC_MULTI_LINE_DELIMITER)
        Splits(sr, 2) = UBound(Splits(sr, 1))
        drCount = drCount + Splits(sr, 2) + 1 _
            + KEEP_BLANKS * (Splits(sr, 2) = -1)
    Next sr
    
    ' Transform (source array (split array) to destination array).
    
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To cCount)
    drCount = 1 ' skip headers
    
    Dim c As Long, n As Long
    
    ' Write headers.
    For c = 1 To cCount
        dData(1, c) = sData(1, c)
    Next c
    
    ' Write data.
    For sr = 2 To srCount
        Select Case Splits(sr, 2)
            Case -1
                If KEEP_BLANKS Then
                    drCount = drCount + 1
                    For c = 1 To cCount
                        dData(drCount, c) = sData(sr, c)
                    Next c
                End If
            Case 0
                drCount = drCount + 1
                For c = 1 To cCount
                    dData(drCount, c) = sData(sr, c)
                Next c
            Case Else
                For n = 0 To Splits(sr, 2)
                    drCount = drCount + 1
                    For c = 1 To cCount
                        If c = SRC_MULTI_LINE_COLUMN Then
                            dData(drCount, c) = Splits(sr, 1)(n)
                        Else
                            dData(drCount, c) = sData(sr, c)
                        End If
                    Next c
                Next n
        End Select
    Next sr
    
    ' Write (destination array to destination range).
    
    ' Reference.
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
    Dim dcell As Range: Set dcell = dws.Range(DST_FIRST_HEADER_CELL_ADDRESS)
    Dim drg As Range: Set drg = dcell.Resize(drCount, cCount)
    ' Clear.
    dcell.Resize(dws.Rows.Count - dcell.Row + 1, cCount).Clear
    ' Write.
    drg.Value = dData
    ' Format e.g.:
    drg.Rows(1).Font.Bold = True
    drg.EntireColumn.AutoFit
    
    ' Inform.
    
    If DISPLAY_MESSAGES Then
        MsgBox "Data transformed to single line.", vbInformation, PROC_TITLE
    End If
    
End Sub