Sub ertert()
Dim i&, j&, k&, sp, clm&
Application.ScreenUpdating = False
clm = Cells(1, Columns.Count).End(xlToLeft).Column
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
k = UBound(Split(Cells(i, 1), Chr(10)))
If k > 0 Then
Rows(i + 1).Resize(k).Insert Shift:=xlDown
For j = 1 To clm 'clm is 8 in your example
sp = Split(Cells(i, j), Chr(10))
Cells(i, j).Resize(k + 1).Value = Application.Transpose(sp)
Next j
End If
Next i
ActiveSheet.UsedRange.EntireRow.AutoFit
Application.ScreenUpdating = True
End Sub
Bookmarks