Sub Sortieren()
'* Dimensionierung der Variablen
Dim wb As Workbook
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim strTeilstring()   As Variant
Dim strTrennzeichen As String

'** Trennen von Zellinhalten an einem vorgegebenen Trennzeichen

'* Vorgaben definieren
Set wsakt = Worksheets(1)
strTrennzeichen = ", " 'Trennzeichen festlegen z.B. Komma(,) Semikolon(;) Bindestrich(-) etc.
Leerzeichen = " "

'* Durchlaufen aller Datenzeilen
LastRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).row
NextCol = 3 '=> PLZ // 4 => Ort
For x = 3595 To 3636
    y = 2
    DoEvents

    stext = Cells(x, y).Value ' den Text holen
Def:
    iPos = InStr(stext, strTrennzeichen)  ' Komma-Position feststellen
    iPosL = InStr(stext, " ") ' Leerzeichen-Position feststellen

    If (UBound(Split(stext, strTrennzeichen)) > 2) Then ' wenn Stra?e, Nr., Ort, PLZ, Land
U3Null:
        While (UBound(Split(stext, strTrennzeichen)) > 1)
            If (Len(Left(stext, iPos - 1)) = 5 And IsNumeric(Left(stext, iPos - 1))) Then
                If IsEmpty(Cells(x, 3).Value) = False Then
                    Cells(x, 4).Value = Cells(x, 3).Value
                    y = 4
                    Cells(x, 3).Value = Left(stext, iPos - 1)
                    stext = Right(stext, Len(stext) - iPos - 1)
                    iPos = InStr(stext, strTrennzeichen)
                    GoTo U3Null
                Else
                Cells(x, 3).Value = Left(stext, iPos - 1)
                End If
            End If
            Cells(x, y).Value = Left(stext, iPos - 1)
            stext = Right(stext, Len(stext) - iPos - 1)             ' Eingabetext "verk?rzen"

            iPos = InStr(stext, strTrennzeichen)                    ' Komma suchen
            If (y < 4) Then
                y = y + 2                                           ' Zeile nach LastRow errechnen
                Cells(x, y).Value = stext                           ' letztes Wort ?bertragen
            End If
        Wend
    End If

    If (UBound(Split(stext, strTrennzeichen)) = 2) Then             ' wenn Stra?e Nr., PLZ Ort, Land
U2Null:
        While (UBound(Split(stext, strTrennzeichen)) > 1)
            Cells(x, y).Value = Left(stext, iPos - 1)               ' Stra?e einf?gen
            stext = Right(stext, Len(stext) - iPos - 1)             ' Eingabetext "verk?rzen"
            iPos = InStr(stext, strTrennzeichen)                    ' Komma suchen
            iPosL = InStr(stext, " ")                               ' Leerzeichen suchen
            If (Len(stext) = 5 And IsNumeric(stext)) Then           ' Falls nur PLZ
                If IsEmpty(Cells(x, 3).Value) = False Then
                    Cells(x, 4).Value = Cells(x, 3).Value
                    y = 4
                    Cells(x, 3).Value = stext
                    stext = Right(stext, Len(stext) - iPos - 1)
                    iPos = InStr(stext, strTrennzeichen)
                    GoTo U2Null
                Else
                Cells(x, 3).Value = Left(stext, iPos - 1)
                End If
            End If
            If (Len(Left(stext, iPos - 1)) = 5 And IsNumeric(Left(stext, iPos - 1))) Then    ' Falls PLZ 1. Element
                If IsEmpty(Cells(x, 3).Value) = False Then
                    Cells(x, 4).Value = Cells(x, 3).Value
                    y = 4
                    Cells(x, 3).Value = stext
                    stext = Right(stext, Len(stext) - iPos - 1)
                    iPos = InStr(stext, strTrennzeichen)
                    GoTo U2Null
                Else
                Cells(x, 3).Value = Left(stext, iPos - 1)
                End If
            End If
            If (Len(Right(stext, Len(stext) - iPos - 1)) = 5 And IsNumeric(Right(stext, Len(stext) - iPos - 1))) Then
                If IsEmpty(Cells(x, 3).Value) = False Then                                  ' Falls PLZ 2. Element
                    Cells(x, 4).Value = Cells(x, 3).Value
                    y = 4
                    Cells(x, 3).Value = stext
                    stext = Right(stext, Len(stext) - iPos - 1)
                    iPos = InStr(stext, strTrennzeichen)
                    GoTo U2Null
                Else
                Cells(x, 3).Value = Right(stext, Len(stext) - iPos - 1)
                Cells(x, 4).Value = Left(stext, iPos - 1)
                End If
                GoTo Weiter
            End If
            If (Len(Left(stext, iPosL - 1)) = 5 And IsNumeric(Left(stext, iPosL - 1))) Then
                If IsEmpty(Cells(x, 3).Value) = False Then  'Wenn Inhalt vorhanden
                    Cells(x, 4).Value = Cells(x, 3).Value
                    y = 4
                    Cells(x, 3).Value = stext
                    stext = Right(stext, Len(stext) - iPos - 1)
                    iPos = InStr(stext, strTrennzeichen)
                    GoTo U2Null
                Else
                Cells(x, 3).Value = Left(stext, iPosL - 1)   'PLZ einf?gen
                End If
                If (UBound(Split(Left(stext, iPos - 1), " ")) = 1) Then
                    Cells(x, 4).Value = Right(Left(stext, iPos - 1), Len(Left(stext, iPos - 1)) - iPosL) 'Ort einf?gen
                    stext = Right(stext, Len(stext) - iPos - 1)
                    GoTo Def
                End If
            End If
            Cells(x, 4).Value = Right(stext, Len(stext) - iPos - 1)        ' Verk?rze stext auf Inhalt nach PLZ (!iPosL!)
        Wend
    End If
U1Null:
    If (UBound(Split(stext, strTrennzeichen)) <= 1) Then            ' wenn 1 Element ?brig
        If (UBound(Split(stext, Leerzeichen)) = 3 And UBound(Split(stext, strTrennzeichen)) = 1) Then
            Cells(x, 2).Value = Left(stext, iPos - 1)               '* Str Nr., PLZ Ort *' F?ge Str Nr. ein
            stext = Right(stext, Len(stext) - iPos - 1)             ' K?rze auf PLZ Ort
            iPos = InStr(stext, strTrennzeichen)                    ' Komma suchen
            iPosL = InStr(stext, " ")                               ' Leerzeichen suchen
            Cells(x, 3).Value = Left(stext, iPosL - 1)
            Cells(x, 4).Value = Right(stext, Len(stext) - iPosL)
            'Cells(x, 4).Value = Right(Left(stext, iPos - 1), Len(Left(stext, iPos - 1)) - iPosL)
        End If
        If (iPos > 0) Then  ' Else If
            If (Len(Left(stext, iPos - 1)) = 5 And IsNumeric(Left(stext, iPos - 1))) Then
                Cells(x, 3).Value = Left(stext, iPos - 1)           ' wenn PLZ
            Else
                Cells(x, 4) = Left(stext, iPos - 1)                 ' wenn Ort
            End If
        End If
    End If

'  '* Teilstring am Delimiter auslesen
'    strTeilstring = Split(Trim(wsakt.Cells(x, 2).Value), strTrennzeichen)
'
'  '* Durchlaufen des gesamten Arrays einer Zelle vom ersten bis zum letzten Wert
'  For a = LBound(strTeilstring) To UBound(strTeilstring)
'
'    '* Array-Elemente nacheinander eintragen
'    wsakt.Cells(x, NextCol).Value = Trim(strTeilstring(a))
'
'    '* Zeilenz?hler erh?hen
'    NextCol = NextCol + 1
'  Next a
Weiter:
Next x

End Sub