VBA, convert cells with several paragraphs of text ->splitting paragraphs down into new cells

Question

I have a spreadsheet with data like this:Spreadsheet Overview Image

In Column "A" I have multiple cells that are multiple paragraphs. Ideally my goal is to break each cell into multiple cells below (or rows below) - separated by paragraphs. My struggle is that there is already data below each existing Column "A" data set. So we would need to insert a custom number of rows determined by existing paragraphs and then transpose down. Ideally I would set this up VBA; but a formula is fine as well.

End Goal: End Goal

If anyone can help out with a solution that would be greatly appreciated.

What I have tried:

1. Inserting several new columns after column "A" - the problem here is that unsure the number of new columns needed as numbers of paragraphs in cell can vary. One solution to this is to copy column "A" onto new sheet and work there. 2)Text to columns Feature - (I wish that Excel had a text to Rows instead) -> Delimited by "Other" -> "CTRL + J" (Line Breaks) -> Finish; THEN: Insert rows below and TRANSPOSE down.

I have existing VBA for text to columns but I am seeking higher knowledge.

Sub Delimit()
'splits Text active cell using ALT+10 char
Dim splitVals As Variant
Dim totalVals As Long
Dim i As Integer

For i = 1 To 1000
splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
ActiveCell.Offset(1, 0).Activate
Next i

End Sub

Unsure how to apply this to range of all cells in Column "A" with text and subsequently add in required rows below original rows to accomplish

Answer 1

You could try this:

Sub test()

    Dim inputrange As Range, textarray
    Set inputrange = ActiveSheet.Range("A1:A1000") 'alter this to suit
    
    textarray = Split(Application.WorksheetFunction. _
                TextJoin(Chr(10), True, inputrange), Chr(10))
    inputrange.End(xlDown).Resize _
        (1 + UBound(textarray) - inputrange.Rows.Count).EntireRow.Insert (xlDown)

    inputrange.Cells(1).Resize(1 + UBound(textarray), 1).Value = _
                WorksheetFunction.Transpose(textarray)
 
 End Sub

And here is a second version to work around the 32k length limitation of TextJoin:

Sub test_v2()

    Dim inputrange As Range, c As Range, textarray, StrText As String
    Set inputrange = ActiveSheet.Range("A1:A1000")
    
    For Each c In inputrange
        StrText = StrText & c.Value & Chr(10)
    Next
    
    textarray = Split(StrText, Chr(10))
    
    inputrange.End(xlDown).Resize _
            (1 + UBound(textarray) - inputrange.Rows.Count).EntireRow.Insert (xlDown)
    
    inputrange.Cells(1).Resize(1 + UBound(textarray), 1).Value = _
                WorksheetFunction.Transpose(textarray)
 
 End Sub