'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private temp As String
Private j As Integer
Private ist_ziffer As Boolean

Const ziffern = "0123456789"
Const ziffern_oder_text = "/*.,Ee+-"
Const ziffern_vz = "+-"

Sub teile_string()
Dim z As Range
Dim i As Integer
Dim zeichen As String

For Each z In Selection
      'Startwerte setzen
      temp = z.Text
      i = 1
      j = 0
      zeichen = Mid(temp, 1, 1)
      
      ist_ziffer = False
      
      If InStr(1, ziffern, zeichen) > 0 Then ist_ziffer = True
      If InStr(1, ziffern_vz, zeichen) > 0 And InStr(1, ziffern, Mid(temp, 2, 1)) > 0 Then ist_ziffer = True
      
      'Inhalt aufsplitten
      Do While Len(temp) > 0
          Select Case ist_ziffer
              Case True: 'finde das Ende der Zahl
                  z.Offset(0, j) = extrahiere_zahl(temp)
                  Call split_zahl(z, z.Offset(0, j), "-", False)
              Case Else: 'finde Textende
                  z.Offset(0, j) = extrahiere_text(temp)
                  If j > 1 Then Call lösche_sperrworte(z, z.Offset(0, j))
              End Select
      'Call sortiere_zellen2(z, 3, 4)
      Loop
Next z
End Sub

Private Function extrahiere_zahl(ByVal t As String) As String
On Error Resume Next
Dim pos As Integer
pos = 0
extrahiere_zahl = "'" & t
If Len(t) < 2 Then
    j = j + 1
    temp = ""
    ist_ziffer = False
    Exit Function
    End If
Do While ist_ziffer
   ist_ziffer = False
   pos = pos + 1
   Select Case Mid(t, pos, 1)
       Case "0" To "9": 'definitiv eine Ziffer, also weiter
           ist_ziffer = True
       Case "-", "+", "/", "*", ",", ".": 'evtl Tausendertrennung oder ähnliches?
           If Len(t) > pos Then
               If InStr(1, ziffern, Mid(t, pos + 1, 1)) > 0 Then ist_ziffer = True
               End If
       Case " ":  'hier beginnt wieder Text
           'ist_ziffer = False wurde oben gesetzt!
       Case "E", "e": 'Exponent?
           'ist_ziffer = False
           If Len(t) > 1 Then
               If InStr(1, ziffern & ziffern_vz, Mid(t, pos + 1, 1)) > 0 Then ist_ziffer = True
               End If
       Case Else: 'definitiv keine Ziffer
           'ist_ziffer = False
       End Select
Loop
j = j + 1
temp = Trim(Right(t, Len(t) - pos + 1))
extrahiere_zahl = "'" & Trim$(CStr(Left$(t, pos - 1)))
End Function


Private Function extrahiere_text(ByVal t As String) As String
On Error Resume Next
Dim pos As Integer
pos = 0
extrahiere_text = t
If Len(t) < 2 Then
    j = j + 1
    temp = ""
    ist_ziffer = True
    Exit Function
    End If
Do While Not ist_ziffer
   pos = pos + 1
   Select Case Mid(t, pos, 1)
       Case "0" To "9": 'definitiv eine Ziffer
           ist_ziffer = True
       Case "-", "+": 'evtl Vorzeichen?
           If Len(t) > 1 Then
               If InStr(1, ziffern, Mid(t, pos + 1, 1)) > 0 Then ist_ziffer = True
               End If
       Case Else: 'definitiv keine Ziffer
         'ist_ziffer = False
       End Select
Loop
j = j + 1
temp = Trim(Right(t, Len(t) - pos + 1))
extrahiere_text = Trim(Left(t, pos - 1))
End Function

Private Sub split_zahl(z As Range, ByVal t As String, Optional splitchar = "-", Optional zeige_splitchar = True)
'trenne Zahlen wenn durch Minuszeichen verbunden
Dim pos As Integer
t = WorksheetFunction.Substitute(t, "'", "")
pos = InStr(1, t, splitchar)
   If pos > 1 Then
      z.Offset(0, j) = "'" & Trim$(CStr(Left$(t, pos - 1)))
      If zeige_splitchar Then
          j = j + 1
          z.Offset(0, j) = "-"
          End If
      j = j + 1
      z.Offset(0, j) = "'" & Trim$(CStr(Right$(t, Len(t) - pos)))
   End If
End Sub

Private Sub lösche_sperrworte(z As Range, ByVal t As String)
'lösche bestimmte Worte und setze den Index j zurück,
'wenn der restliche String ein Leerstring ist!
Dim sw(1) As String
Dim i As Integer
sw(1) = "bis"
t = Trim(t)

For i = 1 To UBound(sw)
   If InStr(1, t, sw(i)) > 0 Then
       t = Trim(WorksheetFunction.Substitute(t, sw(i), ""))
       If Len(t) > 0 Then
           z.Offset(0, j) = t
           Else
           j = j - 1
           End If
       End If
Next i
End Sub

Private Sub sortiere_zellen(z As Range, start_offset As Integer, end_offset As Integer)
'setze alle "Zahlen" an den Anfang des Offsetbereiches und
'alle "Texte" ans Ende ... evtl gibt es danach Leerzellen dazwischen
Dim zpointer As Integer
Dim gefunden As Boolean
Dim hilsvar As String

Do While start_offset < end_offset
gefunden = False
    If InStr(1, ziffern, Left(z.Offset(0, start_offset), 1)) > 0 Then
        start_offset = start_offset + 1
        Else
        zpointer = start_offset + 1
        Do While zpointer <= end_offset
        If InStr(1, ziffern, Left(z.Offset(0, zpointer), 1)) > 0 Then
            gefunden = True
            hilfsvar = z.Offset(0, zpointer - 1)
            z.Offset(0, zpointer - 1) = z.Offset(0, zpointer)
            z.Offset(0, zpointer) = hilfsvar
            End If
        zpointer = zpointer + 1
        Loop
        If Not gefunden Then start_offset = start_offset + 1
     End If
Loop
End Sub

Private Sub sortiere_zellen2(z As Range, Optional i = 1, Optional tpointer = 0)

'funktioniert noch nicht wie gewünscht!

Dim hilsvar As String
   If j > i Then
       If InStr(1, ziffern, Left(z.Offset(0, j), 1)) > 0 And _
           InStr(1, ziffern, Left(z.Offset(0, j - 1), 1)) < 1 Then
            hilfsvar = z.Offset(0, j - 1)
            z.Offset(0, j - 1) = z.Offset(0, j)
            z.Offset(0, j) = hilfsvar
            j = j + 1
            End If
        Else
       If InStr(1, ziffern, Left(z.Offset(0, j), 1)) < 1 And _
             z.Offset(0, j + 1) = "" And _
             j < tpointer And j > 1 Then
            hilfsvar = z.Offset(0, j)
            z.Offset(0, j) = z.Offset(0, j + 1)
            z.Offset(0, j + 1) = hilfsvar
            j = j - 1
            End If
        End If
End Sub