Sub CRTextAufteilen()
Dim VarText, TextBisCR As String
VarText = Sheets("Tabelle1").Cells(4, 3)  '' =C4
Beg = 1
Do
  PosCR = InStr(Beg, VarText, Chr(10), 1)
  If (PosCR > 0) Then
      TextBisCR = Mid(VarText, Beg, PosCR - Beg)
      Beg = PosCR + 1
    Else
      If (Beg > 0) Then
        TextBisCR = Mid(VarText, Beg, Len(VarText) - Beg + 1)
        Beg = 0
      End If
  End If
  ActiveCell.Next.Select
  ActiveCell = TextBisCR
Loop While Beg > 0

end Sub

Sub Makro2()

Dim c As Range
Dim maxSp, Sp1, Zeilen As Integer
maxSp = 0
Zeilen = Range("A65536").End(xlUp).Row
For i = 1 To Zeilen
  Cells(i, 1).Select
  maxSp = Application.WorksheetFunction.Max(CRTextAufteilenR(ActiveCell, Chr(10)), maxSp)
Next i
''' rechtsbündig ausrichten
'For i = 1 To Zeilen
'  For Sp = maxSp + 3 To 2 Step -1
'    Set c = Cells.Find(What:="*", After:=Cells(i, Sp), SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues)
'    If (c.Column < 2) Then Exit For
'    c.Cut
'    ActiveSheet.Paste Destination:=Cells(i, Sp + 3)
'  Next Sp
'Next i

End Sub


Function CRTextAufteilenR(c As Range, Trennung As String)
'
' CRTextAufteilen Makro
' Trennung z.B. "\" oder auch Chr(10)

Dim VarText, TextBisCR, Sp As String
VarText = c
Beg = 1
Sp = 0
Do
  PosCR = InStr(Beg, VarText, Trennung, 1)
  If (PosCR > 0) Then
      TextBisCR = Mid(VarText, Beg, PosCR - Beg)
      Beg = PosCR + 1
      Sp = Sp + 1
    Else
      If (Beg > 0) Then
        TextBisCR = Mid(VarText, Beg, Len(VarText) - Beg + 1)
        Beg = 0
        Sp = Sp + 1
      End If
  End If
  ActiveCell.Next.Select
  ActiveCell = TextBisCR
Loop While Beg > 0

CRTextAufteilenR = Sp
End Function