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.

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

    stext = Cells(x, y).Value ' den Text holen
    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 (iPos > 0)
            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 + 1                                       ' 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 (iPos > 0)
            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 (Len(stext) = 5 And IsNumeric(stext)) Then
                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
            iPosL = InStr(stext, " ")
            '****DEBUGGING****'
            If (Len(Left(stext, iPosL - 1)) = 5 And IsNumeric(Left(stext, iPosL - 1))) Then
            '****DEBUGGING****'
                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
            End If
            If (y < 4) Then
                y = y + 1                                       ' Zeile nach LastRow errechnen
                Cells(x, y).Value = stext                             ' letztes Wort ?bertragen
            End If
        Wend
    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
Next x

End Sub