Sub Demo()
Application.ScreenUpdating = False
Dim lRow As Long, r As Long, lCol As Long, c As Long
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
With ThisWorkbook.Worksheets("Sheet1")
  With .UsedRange.Cells.SpecialCells(xlCellTypeLastCell)
    lRow = .Row
    lCol = .Column
  End With
  For r = lRow To 1 Step -1
    For c = 1 To lCol
      j = UBound(Split(.Cells(r, c).Value, Chr(10)))
      For i = 1 To j
        With .Rows(r).EntireRow
          .Copy
          .Insert Shift:=xlDown
        End With
      Next
      If j > 0 Then Exit For
    Next
    If j > 0 Then
      For k = c To lCol
        l = UBound(Split(.Cells(r, k).Value, Chr(10)))
        If l > 0 Then
          n = j
          For m = r + j To r Step -1
            .Cells(m, k).Value = Split(.Cells(r, k).Value, Chr(10))(n)
            n = n - 1
          Next
        End If
      Next
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub