Splitting paragraphs in cells into several cells

[mthwi]

Hello, everyone,


i have uploaded the following table.
In worksheet 'Before' is the before-state (1. Image below)
See document Before.png.

In the worksheet 'After' is the after-state (2. Image blow)
See document After.png.

I also attached an excel file.

The cells containing texts with paragraphs are to be distributed on cells.
It is important that the number of columns and rows can vary.
This is just a small example.

I am looking forward to a solution. VBA would be great.

Thanks and greetings.

[NoSparks]

Are you sure that row 8 from the "Before" sheet is to result in row 14 on the "After" sheet ?

[p45cal]

In the attached is a macro blah, which can be run by clicking the button on sheet Before. It asks for the source range to process which initially defaults to an area beginning at row 4 (because I doubt you'll want to process row 3). If you don't cancel at this stage then it'll then ask for a destination range, which I've initially defaulted to A24 of the After sheet. Again, if you don't cancel it'll process what you've asked it to and put the results at the destination.

For those interested this is the code:

Sub blah()
Dim Rng As Range, Destn As Range
Static SourceRngAddress As String
Static DestnAddress As String
If SourceRngAddress = "" Then SourceRngAddress = "A4:F11"
On Error Resume Next
Set Rng = Application.InputBox("Select range to process…", "Select range", SourceRngAddress, Type:=8)
On Error GoTo 0
If Not Rng Is Nothing Then
  SourceRngAddress = Rng.Address(External:=True)
  If DestnAddress = "" Then DestnAddress = "After!$A$24"
  On Error Resume Next
  Set Destn = Application.InputBox("Select destination…", "Select range", DestnAddress, Type:=8)
  On Error GoTo 0
  If Not Destn Is Nothing Then
    DestnAddress = Destn.Address(External:=True)

    x = Rng
    ReDim RowsNeeded(1 To UBound(x))
    For rw = 1 To UBound(x)
      MaxLinesCount = -9
      For Colm = 1 To UBound(x, 2)
        y = Split(x(rw, Colm), vbLf)
        LinesCount = UBound(y)
        MaxLinesCount = Application.Max(MaxLinesCount, LinesCount)
      Next Colm
      '  Rng.Rows(rw).Select
      '  MsgBox rw & " has " & MaxLinesCount + 1 & " lines"
      RowsNeeded(rw) = MaxLinesCount + 1
    Next rw
    xx = Application.Sum(RowsNeeded)
    ReDim Results(1 To xx, 1 To UBound(x, 2))
    DestnRow1 = 1
    For rw = 1 To UBound(x)
      For Colm = 1 To UBound(x, 2)
        DestnRow = DestnRow1
        y = Split(x(rw, Colm), vbLf)
        For i = LBound(y) To UBound(y)
          Results(DestnRow, Colm) = y(i)
          DestnRow = DestnRow + 1
        Next i
      Next Colm
      DestnRow1 = DestnRow1 + RowsNeeded(rw)
    Next rw
    Destn.Resize(UBound(Results), UBound(Results, 2)).Value = Results
    Application.Goto Destn
  End If
End If
End Sub