User Tools

Site Tools


vba:functions:strreplace

[VBA] strReplace()

Diese Funktion ermöglicht es, mehrere Ersetzungen Gleichzeitig durchszuführen ohne dass sich diese gegenseitig in die Quere kommen.

Version 1.2.0 - 12.11.2014

Ein Beispiel im Direktfenster. Im Text 'Hans schlägt Fritz worauf Fritz zu Boden geht' will ich Hans durch Fritz ersetzen und Umgekehrt. Die klassische Art wäre mit 2 verschachtelten Replace.

'Erst Hans zu Fritz und dann Fritz zu Hans
? replace(replace("Hans schlägt Fritz worauf Fritz zu Boden geht", "Hans", "Fritz"), "Fritz", "Hans")
Hans schlägt Hans worauf Hans zu Boden geht
 
'2ter Versuch. Fritz zu Hans und dann Hans zu Fritz
? replace(replace("Hans schlägt Fritz worauf Fritz zu Boden geht", "Fritz", "Hans"), "Hans", "Fritz")
Fritz schlägt Fritz worauf Fritz zu Boden geht

Dasselbe mit strReplace(). Diesmal bekomme ich das gewünschte Resultat

? strReplace("Hans schlägt Fritz worauf Fritz zu Boden geht", "Hans", "Fritz", "Fritz", "Hans")
Fritz schlägt Hans worauf Hans zu Boden geht

Die Funktion lässt sich auf verschieden Arten anwenden. Mehr dazu unter den Beispielen. Die Suchbegriffe können auch Reguläre Ausdrücke sein und im Replace kann auf die Submatches zugegriffen werden.

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

Definition

string = strReplace(string, find1, replace1 [,find2, replace2...[,find#, replace#]])
string = strReplace(string, array(find1 [,find2...[find#]]), array(replace1 [,replace2...[,replace#]]))
string = strReplace(string, dictionary1 [,dictionary2...[dictionary#]])
Public Function strReplace( _
        ByVal iExpression As Variant, _
        ParamArray iItems() As Variant _
) As String
  • iExpression Der String, der bearbeitet werden soll
  • iItems ParamArray mit den verschiedenen Parameters.

Verschiedene Anwendungsmöglichkeiten

Es gibt 4 verschiedene Varianten. Die genaueren Beschreibung kann man bei der Funktion [VBA] cDict() nachschauen. cDict() wird intern verwendet um die Parametervielfallt abzudecken

1) Abwechselnd Find/Replace

string = strReplace(string, find1, replace1 [,find2, replace2...[,find#, replace#]])

Die Suchbegriffe und die Ersetzungsstrings wechseln sich ab

2) Kombination mit 2 Arrays

string = strReplace(string, array(find1 [,find2...[find#]]), array(replace1 [,replace2...[,replace#]]))

Man übergibt 2 Arrays. Der Ersete beinhaltet alle Suchbegriffe, der 2te die Ersetzungsstrings

3) Dictionary

string = strReplace(string, dictionary1 [,dictionary2...[dictionary#]])

Die Argumente werden als Dictionary übergeben. Der Key ist dabei jeweils der Suchbegriff, der Value der Ersetzungsstring

4) Set-String

string = strReplace(string, string)

Die Ersetzung können als Zuordnungsstring übergeben werden

String als Regulärer Ausdruck

Die Suchstrings können als Reguläre Ausdrücke daherkommen. Dazu müssen sie wie in PHP für preg_match() mittels Delemiter und Modifiers formatiert werden.

[Delemiter][Regulärer Ausdruck][Delemiter][Modifiers]

Delemiter

Als Delemiter können die folgenden Zeichen verwendet werden

@&!/~#=|

Modifiers

Es gibt 3 Modifier.Genau soviele wie die RegExp-Klasse Properties hat. Die Grosskleinschreibung wird nicht berücksichtig. Ebensowenig die Reihenfolge.

  • i IgnoreCase
  • g Global
  • m Multiline

Beispiele zum String als regExp

Es sind dieselben Pattern wie auch für [VBA] cRegExp(), cRx() gültigkeit haben

'Ohne Parameters und / als Delemiter
d cRegExp("/ABC ([a-k]*)/")
<IRegExp2>  (
    [Pattern] => <String> 'ABC ([a-k]*)'
    [Global] => <Boolean> False
    [IgnoreCase] => <Boolean> False
    [Multiline] => <Boolean> False
)
 
'Mit IgnoreCase und @ asl Delemiter
d cRegExp("@ABC ([a-k]*)@i")
<IRegExp2>  (
    [Pattern] => <String> 'ABC ([a-k]*)'
    [Global] => <Boolean> False
    [IgnoreCase] => <Boolean> True
    [Multiline] => <Boolean> False
)
 
'IgnoreCase und Multiline und ! als Delemiter. Im Pattern selber kommt auch ein ! vor, wird korrekterweise nicht als Delemiter erkannt
d cRegExp("!ABC! ([a-k]*)!im")
<IRegExp2>  (
    [Pattern] => <String> 'ABC! ([a-k]*)'
    [Global] => <Boolean> False
    [IgnoreCase] => <Boolean> True
    [Multiline] => <Boolean> True
)

Beispiele zu strReplace

d strReplace("D123-X12; Bratpulver", "X12", "ID:12")
<String> 'D123-ID:12; Bratpulver'
 
d strReplace("D123-X12; Bratpulver", "brat", "Koch", "pulver", "wasser")
<String> 'D123-X12; Kochwasser'
 
'Ganz normal mit 2 Suchbegriffen und 2 Ersetzungstexte
d strReplace("P1 schlägt P2 worauf P2 zu boden geht", "P1", "P2", "P2", "P1")
<String> 'P2 schlägt P1 worauf P1 zu boden geht'
 
'Mit 2 Arrays: der erste Array beinhaltet die Suchbegriffe, der 2te die Ersetzungstexte
d strReplace("D123-X12; Bratpulver", array("brat", "pulver"), array("Koch", "wasser"))
<String> 'D123-X12; Kochwasser'
 
'Als Regulärer. Der Erste mit IgnoreCase, der 2te Ohne
d strReplace("D123-X12; Bratpulver (D123)", "/-x(\d+);/i", "-ID:$1;", "/^D(\d{1,3})/", "PREFIX:$1")
<String> 'PREFIX:123-ID:12; Bratpulver (D123)'
 
'Dasselbe wieder mit den 2 Arrays
d strReplace("D123-X12; Bratpulver (D123)", array("/-x(\d+);/i", "/^D(\d{1,3})/"), array("-ID:$1;", "PREFIX:$1"))
<String> 'PREFIX:123-ID:12; Bratpulver (D123)'
 
'Wenn wir das IgnoreCase weglassen, findet er den String nicht mehr
d strReplace("D123-X12; Bratpulver", "/-x(\d+);/", "-ID:$1;")
<String> 'D123-X12; Bratpulver'
 
'Wir haben im Such-Array mehr Einträge als im Ersetzungsarray: Es wird der letzte Ersetzungsstring für alle Weiteren verwendet
'Das Ausrufezeichen wird ebenfalls durch _ ersetzt, gneau wie alle Treffer des 2ten Patterns
'zudem sieht mann, dass der erste Suchbegriff vorrang hat, falls sich diese überschneiden. Der erste macht aus einem ö ein ue, der Zweite würde gerne aus einem ü ein _ machen
d strReplace("Öl gibts bald nicht mehr! Dafür wasser", array( "ö", "/[äöü]/i", "!"), array("oe", "_"))
<String> 'oel gibts bald nicht mehr_ Daf_r wasser'
 
'und noch ein Versuch Mmittels Zuordnungsstring
d strReplace("ABC", "'a'=>'b', 'b':'c'")
<String> 'bcC'

Und ein Beispiel mit Dictionary als Argument

Public Sub testStrReplace()
    Dim dict As New dictionary
    dict.add "A", "_a_"
    dict.add "/[a-z]/i", "{$1}"
    dict.add "C", "_c_"
 
    d strReplace("A B C 1", dict)
End Sub
 
<String> '_a_ {$1} {$1} 
1'

Code

udf_strreplace.bas
Attribute VB_Name = "udf_strReplace"
'-------------------------------------------------------------------------------
'File         : udf_strReplace.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions
'Environment  : VBA 2010 +
'Version      : 1.2.0
'Name         : strReplace
'Author       : Stefan Erb (ERS)
'History      : 04.09.2014 - ERS - Creation
'               08.09.2014 - ERS - neue Version cDict() implementiert
'               31.10.2014 - ERS - Cache auf Static umgestellt
'               12.11.2014 - ERS - auf cDict V.3.0.0 upgraded
'-------------------------------------------------------------------------------
Option Explicit
 
Public Const ERR_strReplace_INVALID_ARGUMENT_COUNT = vbObjectError + 501   'Der ParamArray hat eine ungerade Anzahl Argumente
 
'Modifier i IgnoreCase
'Modifier m Multiline
'Modifier g Global
 
'-------------------------------------------------------------------------------
' -- Public metodes
'-------------------------------------------------------------------------------
 
'/**
' * Ersetz in einem String mehrere Substrings. Normal oder mit RegExp
' * @param  String      Der Text, ind em ersetzt werden soll
' * @param  ParamArray  Die Ersetzungsargumente
' * @return String
' */
Public Function strReplace( _
        ByVal iExpression As Variant, _
        ParamArray iItems() As Variant _
) As String
    Dim items() As Variant: items = CVar(iItems)
    'Parameters zusammenstellen: Dictionary([Pattern] => [Replace])
    Dim dict As Dictionary: Set dict = cDictA(items)
'Set dict = createDictFromExpressions(items)
    'If ((UBound(items) + 1) Mod 2) > 0 Then Err.Raise ERR_strReplace_INVALID_ARGUMENT_COUNT, "Invalid Number of Values"
    'Keys extrahieren, da bei Latebinding nicht über den ndex auf das Dictionary zugegriffen werden kann
    Dim keys() As Variant: keys = dict.keys
    'Aufbrösmeln: repl = array(flRx => [RegExp des einzelnen Suchwertes], flReplace => [Ersatzstring])
    Dim repl() As Variant: ReDim repl(dict.count - 1)
    Dim idxI As Integer: For idxI = 0 To dict.count - 1
        Dim searchPattern As String: searchPattern = keys(idxI)                 'Suchpattern auslesen
        If rxPattern.test(searchPattern) Then                                   'Falls gültiger Pattern
            searchPattern = rxPattern.execute(searchPattern)(0).subMatches(1)   'Den eigentlichen Pattern extrahieren
            repl(idxI) = Array(cRegExp(keys(idxI)), dict(keys(idxI)))            'und den Array zusammenstellen
        Else
            searchPattern = escapeString(searchPattern)                         'Pattern Escapen, damit es kein RegExp-Search gibt
            repl(idxI) = Array(cRegExp("/" & searchPattern & "/i"), dict(keys(idxI)))
        End If
        Dim pp() As String: ReDim Preserve pp(idxI): pp(idxI) = "(" & searchPattern & ")"   'Alle SearchPattern in einme Array sammeln
    Next idxI
    Dim pattern As String: pattern = "(?:" & Join(pp, "|") & ")"                'und zu einem grossen Pattern zusammensetzen: (?(pattern1)|(pattern2)...|(patternN))
    Dim rx As Object: Set rx = cRegExp("/" & pattern & "/gi")        'und damit ein GesammtsuchRegExp erstellen
 
    strReplace = iExpression
 
    Dim mc As Object: Set mc = rx.execute(iExpression)                          'Gesammtsuche ausführen
    Dim idxM As Integer: For idxM = mc.count - 1 To 0 Step -1
        Dim arr As Variant: For Each arr In repl                                'Für jeden Treffer den richtigen TeilRegExp suchen und den Teilstring ersetzen
            If arr(0).test(mc(idxM).value) Then
                strReplace = substrReplace( _
                        iString:=strReplace, _
                        iReplacement:=arr(0).Replace(mc(idxM).value, arr(1)), _
                        iStart:=mc(idxM).firstIndex, _
                        iLength:=mc(idxM).length _
                )
                Exit For
            End If
        Next arr
    Next idxM
 
End Function
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Escapte alle Sonderzeichen um eine rx-Pattern zu erstellen
' *
' *     string = rx_escape_string(string)
' *
' * @example    rx_escape_string("Hallo Welt. Geht es dir (noch) gut?")
' *             Hallo Welt\. Geht es dir \(noch\) gut\?
' * @param  String
' * @return String
' */
Private Function escapeString( _
        ByVal iString As String _
) As String
    escapeString = rxEscapeStrings.Replace(iString, "\$1")
End Function
 
 
 
'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------
Private Property Get rxEscapeStrings() As Object
    Static rxCachedEscapeStrings As Object
    If rxCachedEscapeStrings Is Nothing Then Set rxCachedEscapeStrings = cRegExp("/([\\\*\+\?\|\{\[\(\)\^\$\.\#])/g")
    Set rxEscapeStrings = rxCachedEscapeStrings
End Property
 
Private Property Get rxRemoveMarks() As Object
    Static rxCachedRemoveMarks As Object
    If rxCachedRemoveMarks Is Nothing Then Set rxCachedRemoveMarks = cRegExp("/\\(['""])/g")
    Set rxRemoveMarks = rxCachedRemoveMarks
End Property
 
'-------------------------------------------------------------------------------
' -- Private Libraries
'-------------------------------------------------------------------------------
 
'/**
' * Dito zu cDict(). Die Übergabe ist aber nicht ein ParamArray sondern ein Arry.
' * DIeser AUfruf wird vor allem im Einsatz in anderen Funktionen verwendet
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * @param  Array
' * @return Dictionary
' */
Public Function cDictA(ByRef iItems() As Variant) As Object
    Static rxSetString As Object    'Cache RegExp um einSet-String zu zerlegen
    Set cDictA = CreateObject("scripting.Dictionary")
    Dim items() As Variant:     items = CVar(iItems)
    Dim key As Variant, value As Variant
    Dim isList As Boolean
 
    If UBound(items) = -1 Then Exit Function
 
    'Prüfen ob 2 Parametetrs übergeben wurden
    If UBound(items) = 1 Then
        'Beide Parametrer sind Arrays -> Combine: Erster Array Keys, 2ter Values
        If IsArray(items(0)) And IsArray(items(1)) Then
            Dim keys() As Variant:      keys = items(0)
            Dim values() As Variant:    values = items(1)
            Dim delta As Long:          delta = LBound(keys) - LBound(values)
            ReDim Preserve values(LBound(values) To UBound(keys) + delta)
            Dim i As Integer: For i = LBound(keys) To UBound(keys)
                If Not cDictA.exists(keys(i)) Then cDictA.add keys(i), values(i + delta)
            Next i
            Exit Function
        End If
    End If
 
    'Alle Items durchackern
    Dim cnt As Integer:     cnt = 0
    Dim item As Variant:    For Each item In items
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In item.keys
                If Not cDictA.exists(key) Then cDictA.add key, item.item(key)
            Next key
        'einsamer Array
        ElseIf Not isList And IsArray(item) Then
            For key = LBound(item) To UBound(item)
                If Not cDictA.exists(key) Then cDictA.add key, item(key)
            Next key
        'SetString
        ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then
            If rxSetString Is Nothing Then Set rxSetString = cRegExp("/((['""#](?![\\,])).+?\1(?!\\)|[\d\.]*)\s*(?:>=|[:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+)/g")
            If rxSetString.test(StrReverse(item)) Then
                Dim mc As Object: Set mc = rxSetString.execute(StrReverse(item))
                Dim m As Variant: For Each m In mc
                    key = evalCDictString(StrReverse(m.subMatches(2)))
                    value = evalCDictString(StrReverse(m.subMatches(0)))
                    If Not cDictA.exists(key) Then cDictA.add key, value
                Next m
            Else
                GoTo DEFAULT        'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt übergeben wird. Darum konnte der Test nicht im ElseIf durchgeführt werden.
            End If
        'Alles andere geht in ein WertePaar.
        ElseIf cnt = 0 Or isList Then
DEFAULT:
            If cnt Mod 2 = 0 Then
                key = item
            ElseIf Not cDictA.exists(key) Then cDictA.add key, item
            End If
            isList = True
        End If
        cnt = cnt + 1
    Next
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And cnt Mod 2 <> 0 Then
        If Not cDictA.exists(key) Then cDictA.add key, Empty
    End If
End Function
 
 
'-------------------------------------------------------------------------------
'-- Private methodes / properties for cDict()
'-------------------------------------------------------------------------------
 
'/**
' * Parst einen String in Datum, Nummer oder String
' * @param  String
' * @return Variant
' */
Private Function evalCDictString(ByVal iString As String) As Variant
    Static rxDateString As Object
    Static rxDelemitedString As Object
    If rxDateString Is Nothing Then Set rxDateString = cRegExp("/^#.*#$/")
    If rxDelemitedString Is Nothing Then Set rxDelemitedString = cRegExp("/^[#""'\[](.*)([""'#\]])$/") '0: String ohne Delemiter, 1: End-Delemiter: '," oder ]
 
    If IsNumeric(iString) Then
        evalCDictString = eval(iString)  'Zu Zahlenformat konvertieren
    ElseIf rxDateString.test(iString) Then
        evalCDictString = eval(iString)  'Zu Datum konvertieren
    ElseIf rxDelemitedString.test(iString) Then
        Dim sm As Object: Set sm = rxDelemitedString.execute(iString)(0).subMatches
        evalCDictString = Replace(sm(0), "\" & sm(1), sm(1))
    Else
        evalCDictString = iString
    End If
End Function
 
 
 
'/**
' * Erstellt ein RegExp-Object mit den Grundeinstellungen
' * Modifier i IgnoreCase
' * Modifier g Global
' * Modifier m multiLine
' * @param  String          Pattern analog RegExp oder mit Delimiter und Modifier analog zu PHP
' * @param  rxpFlagsEnum    Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return RegExp
' */
Private Function cRegExp(ByVal iPattern As String) As Object
    Set cRegExp = CreateObject("VBScript.RegExp")
    If rxPattern.test(iPattern) Then
        Dim sm As Object: Set sm = rxPattern.execute(iPattern)(0).subMatches
        cRegExp.pattern = sm(1)
        cRegExp.IgnoreCase = sm(2) Like "*i*"
        cRegExp.Global = sm(2) Like "*g*"
        cRegExp.MultiLine = sm(2) Like "*m*"
    End If
End Function
Private Property Get rxPattern() As Object
    Static rxCachedPattern As Object
    If rxCachedPattern Is Nothing Then
        Set rxCachedPattern = CreateObject("VBScript.RegExp")
        rxCachedPattern.pattern = "^([@&!/~#=\|])(.*)\1([igm]{0,3})$"
    End If
    Set rxPattern = rxCachedPattern
End Property
 
'/**
' * Ersetzt Text innerhalb einer Zeichenkette
' * @param  String      Die Eingabezeichenkette
' * @param  String      Die Ersetzungszeichenkette
' * @param  Integer     Start
' * @param  Integer     Länge
' * @return String
' */
Private Function substrReplace(ByVal iString As String, ByVal iReplacement As String, ByVal iStart As Integer, Optional ByVal iLength As Variant = Null) As String
    Dim startP As Integer:  startP = IIf(Sgn(iStart) >= 0, iStart, greatest(Len(iString) + iStart, 1))
    Dim length As Integer:  length = NZ(iLength, Len(iString) - iStart)
    Dim endP   As Integer
 
    Select Case Sgn(length)
        Case 1:     endP = least(startP + length, Len(iString))
        Case 0:     endP = startP
        Case -1:    endP = greatest(Len(iString) + length, startP)
    End Select
 
    substrReplace = Left(iString, startP) & iReplacement & Mid(iString, endP + 1)
 
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Gibt den Grössten aus einer unbestimmten Menge von Werten zurück
' * @param  Keine Objekte
' * @return Grösster Wert
' * @example greatest("Hallo Welt", 42, "Mister-X") -> Mister-X
'*/
Private Function greatest(ParamArray iItems() As Variant) As Variant
    greatest = iItems(UBound(iItems))
    Dim item As Variant: For Each item In iItems
        If NZ(item) > NZ(greatest) Then greatest = item
    Next item
End Function
 
'/**
' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück
' * @param  Keine Objekte
' * @return Grösster Wert
' * @example least("Hallo Welt", 42, "Mister-X") -> 42
'*/
Private Function least(ParamArray iItems() As Variant) As Variant
    least = iItems(LBound(iItems))
    Dim item As Variant: For Each item In iItems
        If NZ(item) < NZ(least) Then least = item
    Next item
End Function
 
vba/functions/strreplace.txt · Last modified: 13.02.2020 08:44:46 by yaslaw