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:

'Quelle: http://www.dbwiki.net/
 
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
   Dim sOut() As String
   Dim 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
   Dim nPos1   As Long
   Dim bIsWord As Boolean
   Dim 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
   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 As String = ",,,Wort_1;;Wort2;;;Wort Nummer 3;;;")
   Dim Arr As Variant
   Dim i   As Long
 
   Arr = SplitWords(s)
   For i = LBound(Arr) To UBound(Arr)
      Debug.Print i, """" & Mid$(Arr(i), 1, 32) & """"
   Next
 
   Arr = SplitWords(s, ",;", False)
   For i = LBound(Arr) To UBound(Arr)
      Debug.Print i, """" & Mid$(Arr(i), 1, 32) & """"
   Next
End Function

Wikilinks