VBA Tipp: Zeichenkette aus einem String mit Delimitern extrahieren

Aus DBWiki
Wechseln zu: Navigation, Suche

Problem

Aus einem String wie z.B. ;Text1;Text;Text2; oder <span>xxx</span> soll der Wert zwischen zwei Tags extrahiert werden.

Lösung:

Public Function ExtractFromString( _
                                 sText As String, _
                                 Optional ByVal SDelimter1 As String = ";", _
                                 Optional ByVal IDelimterCount1 As Integer = 1, _
                                 Optional ByVal SDelimter2 As String = ";", _
                                 Optional ByVal IDelimterCount2 As Integer = 1, _
                                 Optional ByVal RelativAbsolut As Variant = "R", _
                                 Optional ByVal SCompare As Integer = vbBinaryCompare) As String
 '*************************************************************
 '*
 '*  Funktion    :        ExtractFromString
 '*
 '*  Parameter   :        sText              = Suchzeichenkette
 '*                       SDelimter1         = Erster Delimiter
 '*                       IDelimterCount1    = Erstes Vorkommnis Trenner
 '*                       SDelimter2         = Zweiter Delimiter
 '*                       IDelimterCount2    = Zweites Vorkommnis Trenner
 '*                       RelativAbosulut    = Entweder Relativ zum Ersten Delimiter oder
 '*                                            Absolut vom Dateianfang
 '*                       vbBinaryCompare    = Akutell nur vbBinaryCompare
 '*
 '*  Hinweise    :        IDelimterCount müssen größer 0 sein
 '*
 '*  Rückgabe    :        bei Fehler         = ""
 '*                       Erfolgreich        = Textstring
 '*
 '*  Beispielaufruf :
 '*  Debug.Print ExtractFromString("1234;567890;1234567;890;1234567; Bester;  Ein", ";", 1, ";", 1)
 '*
 '*************************************************************
 Dim LenText As Long
 Dim LenSDelimter1 As Long
 Dim LenSDelimter2 As Long
 Dim ErstePosSDelimter1 As Long
 Dim ErstePosSDelimter2 As Long
 Dim SuchPos1 As Long
 Dim SuchPos2 As Long
 Dim i As Long
 Dim j As Long
 Dim k As Long
 Dim RA As Byte
 Dim FND As Byte
 FND = 0
 If RelativAbsolut = "R" Or LCase(RelativAbsolut) = "relativ" Or RelativAbsolut = 1 Then
  RA = 1
 Else
  RA = 0
  If IDelimterCount2 <= IDelimterCount1 Then Exit Function
 End If
 LenText = Len(sText)
 LenSDelimter1 = Len(SDelimter1)
 LenSDelimter2 = Len(SDelimter2)
 'Achtung Differenzierung Relativ und Absolut
 i = 1
 j = 0
 While i <= Len(sText) + 1 And FND = 0
  If RA = 0 Then
    If SDelimter2 = Mid(sText, i, LenSDelimter2) Then
       SuchPos2 = i - 1
       k = k + 1
       If k = IDelimterCount2 Then GoTo Ende
    End If
  End If
  If SDelimter1 = Mid(sText, i, LenSDelimter1) Then
    j = j + 1
    If j = IDelimterCount1 Then
     SuchPos1 = i + LenSDelimter1
     If RA = 1 Then
          'Nur noch nach Delimter2 Parsen
          i = i + LenSDelimter1 + 1
          If RA = 1 Then
            k = 0
          Else
            k = SuchPos1
          End If
          While i <= Len(sText) + 1 - LenSDelimter2 And FND = 0
            If SDelimter2 = Mid(sText, i, LenSDelimter2) Then
              k = k + 1
                If k = IDelimterCount2 Then
                  SuchPos2 = i - 1
                  FND = 1
                End If
            End If
            i = i + 1
          Wend
       End If
    End If
  End If
  i = i + 1
 Wend
 Ende:
   If (SuchPos1 = 0 Or SuchPos2 = 0) Or (SuchPos2 < SuchPos1) Then Exit Function
   ExtractFromString = Mid(sText, SuchPos1, SuchPos2 - SuchPos1 + 1)
End Function

Aufruf

Debug.Print ExtractFromString("1234;567890;1234567;890;1234567; Bester;  Ein", ";", 1, ";", 1)


Wiki hinweis.png Anmerkung: Eignet sich hervorragend um zwischen Tags in HTML Seiten Strings zu extrahieren. Die Tags müssen dabei nicht identisch sein.