Diese Funktion ermöglicht es, mehrere Ersetzungen Gleichzeitig durchszuführen ohne dass sich diese gegenseitig in die Quere kommen.
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().
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
Es gibt 4 verschiedene Varianten. Die genaueren Beschreibung kann man bei der Funktion [VBA] cDict() nachschauen. cDict() wird intern verwendet um die Parametervielfallt abzudecken
string = strReplace(string, find1, replace1 [,find2, replace2...[,find#, replace#]])
Die Suchbegriffe und die Ersetzungsstrings wechseln sich ab
string = strReplace(string, array(find1 [,find2...[find#]]), array(replace1 [,replace2...[,replace#]]))
Man übergibt 2 Arrays. Der Ersete beinhaltet alle Suchbegriffe, der 2te die Ersetzungsstrings
string = strReplace(string, dictionary1 [,dictionary2...[dictionary#]])
Die Argumente werden als Dictionary übergeben. Der Key ist dabei jeweils der Suchbegriff, der Value der Ersetzungsstring
string = strReplace(string, string)
Die Ersetzung können als Zuordnungsstring übergeben werden
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]
Als Delemiter können die folgenden Zeichen verwendet werden
@&!/~#=|
Es gibt 3 Modifier.Genau soviele wie die RegExp-Klasse Properties hat. Die Grosskleinschreibung wird nicht berücksichtig. Ebensowenig die Reihenfolge.
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 )
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'
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