Sub Aufteilen()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.CutCopyMode = False
Dim iSpaltealt, iSpalteneu As Integer
Dim iZeile As Integer
Dim iPosit As Integer
iSpaltealt = 1
iSpalteneu = 2
iZeile = 1
If Len(Range(Cells(iZeile, iSpaltealt), Cells(iZeile, iSpaltealt)).Value) = 0 Then
iZeile = iZeile + 1
Else
Aufteilen:
For iPosit = 1 To Len(Range(Cells(iZeile, iSpaltealt), Cells(iZeile, iSpaltealt)).Value)
If Mid(Range(Cells(iSpaltealt, iZeile), Cells(iSpaltealt, iZeile)).Value, iPosit, 1) = Chr(10) Then
iSpalteneu = iSpalteneu + 1
Else
Range(Cells(iZeile, iSpalteneu), Cells(iZeile, iSpalteneu)).Value = Range(Cells(iZeile, iSpalteneu), Cells(iZeile, iSpalteneu)).Value & _
Mid(Range(Cells(iZeile, iSpaltealt), Cells(iZeile, iSpaltealt)).Value, iPosit, 1)
End If
Next iPosit
End If
iZeile = iZeile + 1
iSpalteneu = 2
If Len(Range(Cells(iSpaltealt, iZeile), Cells(iSpaltealt, iZeile))) > 1 Then GoTo Aufteilen
End Sub