VBA Tipp: Zeichenkette in Wörter zerlegen

Aus DBWiki
Wechseln zu: Navigation, Suche

Problem

Ich möchte einen String analog zur Split-Funktion in einzelne Wörter zerlegen, also als Resultat ein Feld von Wörtern erhalten.

Lösung

Die folgende Funktion erlaubt wahlweise die Definition dessen, was ein "Wort" ausmacht, über die Angabe der zulässigen Zeichen oder über die Begrenzungszeichen:

Public Function SplitWords(ByVal sIn As String, _
  Optional sWordChars, Optional bAllowed As Boolean = True, _
  Optional nLimit As Long = -1, _
  Optional bCompare As Long = vbBinaryCompare) As Variant
Dim sRead As String, sOut() As String, nC As Long
 
  ReDim Preserve sOut(0 to 0)
  If IsMissing(sWordChars) Then
    If bAllowed Then
      ' Diese Zeichen sind im "Wort" erlaubt:
      sWordChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ" & _
                   "abcdefghijklmnopqrstuvwxyzäöüß01234567890"
    Else
      ' oder: Angabe von Begrenzungszeichen:
      sWordChars = ":;,.\()[]=&%""!'? ´`*+"
    End If
  End If
  If sWordChars = "" Then SplitWords = sIn
  Do While sIn <> ""
    sRead = ReadUntilWord(sIn, sWordChars, bAllowed, bCompare)
    ReDim Preserve sOut(nC)
    sOut(nC) = sRead
    nC = nC + 1
    If nLimit <> -1 And nC >= nLimit Then Exit Do
  Loop
  SplitWords = sOut
End Function
 
Private Function ReadUntilWord(ByRef sIn As String, _
    Optional sWordChars, Optional bAllowed As Boolean = True, _
    Optional bCompare As Long = vbBinaryCompare) As String
Dim nPos As Long, nPos1 As Long, bIsWord As Boolean, I As Long
 
  bIsWord = False: nPos1 = 0: nPos = 0
  For I = 1 To Len(sIn)
    If InStr(sWordChars, Mid(sIn, I, 1)) > 0 Eqv bAllowed Then
      If nPos = 0 Then nPos = I
      bIsWord = True
    ElseIf bIsWord Then
      nPos1 = I
      Exit For
    End If
  Next I
  If nPos1 = 0 Then nPos1 = Len(sIn) + 1
  If nPos > 0 Then ReadUntilWord = Mid(sIn, nPos, nPos1 - nPos)
  sIn = Mid(sIn, nPos1)
End Function

Die Funktionsweise zeigt die folgende Testroutine:

Public Function Test_Split(Optional s = ",,,Wort_1;;Wort2;;;Wort Nummer 3;;;")
Dim Arr, I As Long
 
Arr = SplitWords(s)
For I = LBound(Arr) To UBound(Arr)
  Debug.Print I, """" & Mid(Arr(I), 1, 32) & """"
Next I
 
Arr = SplitWords(s, ",;", False)
For I = LBound(Arr) To UBound(Arr)
  Debug.Print I, """" & Mid(Arr(I), 1, 32) & """"
Next I
 
End Function

Siehe auch