Option Explicit
Sub Schaltfläche4_KlickenSieAuf()
Dim rngCell As Range
Dim v As Variant
Dim i As Long, j As Long
Dim letztezeile As Integer, letztezeileneu As Integer
Application.ScreenUpdating = False
j = 1
Do
j = j + 1
letztezeile = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Set rngCell = Cells(j, 2)
v = Split(rngCell.Value, vbLf)
For i = 1 To UBound(v)
Call rngCell.Offset(i - 1).EntireRow.Copy
Call rngCell.Offset(i).EntireRow.Insert(xlShiftDown)
rngCell.Offset(i).Value = v(i)
Next
On Error GoTo Fehler
rngCell.Value = v(0)
letztezeileneu = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Loop Until letztezeile = letztezeileneu + 1
Fehler:
Application.ScreenUpdating = True
End Sub