Option Explicit
Sub aufteilen()
Dim zeil1 As Long
Dim zeil2 As Long
Dim anzahl As Long
Dim anzahl2 As Long
Dim a As Long
Dim b As Long
Dim zellzeil1
Dim zellzeil2
Application.ScreenUpdating = False
zeil1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
zeil2 = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
If zeil1 < zeil2 Then
anzahl = zeil2
Else
anzahl = zeil1
End If
For a = anzahl To 1 Step -1
zellzeil1 = Split(ActiveSheet.Cells(a, 1), vbLf)
zellzeil2 = Split(ActiveSheet.Cells(a, 2), vbLf)
If UBound(zellzeil1) < UBound(zellzeil2) Then
anzahl2 = UBound(zellzeil2)
Else
anzahl2 = UBound(zellzeil1)
End If
For b = anzahl2 - 1 To 0 Step -1
ActiveSheet.Cells(a + 1, 1).EntireRow.Insert Shift:=xlUp
If UBound(zellzeil1) >= b + 1 Then Cells(a + 1, 1) = zellzeil1(b + 1)
If UBound(zellzeil2) >= b + 1 Then Cells(a + 1, 2) = zellzeil2(b + 1)
Next b
If UBound(zellzeil1) >= 0 Then Cells(a, 1) = zellzeil1(0)
If UBound(zellzeil2) >= 0 Then Cells(a, 2) = zellzeil2(0)
Next a
Application.ScreenUpdating = True
End Sub