|
Eine wichtige Operation der Datenverarbeitung ist die Text-Ersetzung, welche in einer Zeichenkette alle Vorkommen eines bestimmten Strings (strOld) durch einen anderen String (strNew) ersetzt. Dazu verwendet man in VBA die Replace-Funktion.
Optional kann die Anzahl der Ersetzungen (Count) und der gewünschte Vergleichsmodus (Compare) angegeben werden.
Nur kleine "n" durch große "M" ersetzen:
strNew = Replace(strOld, "n", "M")
Alle "n" und "N" durch "M" ersetzen:
strNew = Replace(strOld, "n", "M", Compare:=vbTextCompare)
In strOld eine neue Zeile ("Newline") durch HTML-Tag "Break" ersetzen:
ReplaceDo strOld, vbNewLine, "<br>"
Function HTMLEncode(ByRef Text As String) As String
Dim i As Long
Dim Char As Integer
'HTML-Spezies ersetzen:
HTMLEncode = Text
ReplaceDo HTMLEncode, "&", "&"
ReplaceDo HTMLEncode, """", """
ReplaceDo HTMLEncode, "<", "<"
ReplaceDo HTMLEncode, ">", ">"
'Sonderzeichen durch Asc-Code ersetzen:
For i = Len(HTMLEncode) To 1 Step -1
Char = Asc(Mid$(HTMLEncode, i, 1))
Select Case Char:
Case Is < 32, Is >= 160
HTMLEncode = Left$(HTMLEncode, i - 1) & "&#" & Char & ";" & Mid$(HTMLEncode, i + 1)
End Select
Next i
End Function
Public Function Replace(ByRef Text As String, _
ByRef strOld As String, ByRef strNew As String, _
Optional ByVal Start As Long = 1, _
Optional ByVal Count As Long = 2147483647, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
If LenB(strOld) = 0 Then
'Suchstring ist leer:
Replace = Text
ElseIf ContainsOnly0(strOld) Then
'Unicode-Problem, also kein LenB und co. verwenden:
ReplaceBin0 Replace, Text, Text, strOld, strNew, Start, Count
ElseIf Compare = vbBinaryCompare Then
'Groß-/Kleinschreibung unterscheiden:
ReplaceBin Replace, Text, Text, strOld, strNew, Start, Count
Else
'Groß-/Kleinschreibung ignorieren:
ReplaceBin Replace, Text, LCase$(Text), LCase$(strOld), strNew, Start, Count
End If
End Function
'In dieser Prozedur muss keine Rückgabevariable verwaltet werden:
Sub ReplaceDo(ByRef Text As String, _
ByRef strOld As String, ByRef strNew As String, _
Optional ByVal Start As Long = 1, _
Optional ByVal Count As Long = 2147483647, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare)
If LenB(strOld) = 0 Then
'Suchstring ist leer: Nichts machen!
ElseIf ContainsOnly0(strOld) Then
'Unicode-Problem, also kein LenB und co. verwenden:
ReplaceBin0 Text, Text, Text, strOld, strNew, Start, Count
ElseIf Compare = vbBinaryCompare Then
'Groß/Kleinschreibung unterscheiden:
If InStr(Start, Text, strOld, vbBinaryCompare) Then _
ReplaceBin Text, Text, Text, strOld, strNew, Start, Count
Else
'Groß/Kleinschreibung ignorieren:
If InStr(Start, Text, strOld, vbTextCompare) Then _
ReplaceBin Text, Text, LCase$(Text), LCase$(strOld), strNew, Start, Count
End If
End Sub
'Kleine Hilfsfunktion wegen der Unicode-Problematik:
Function ContainsOnly0(ByRef s As String) As Boolean
Dim i As Long
For i = 1 To Len(s)
If Asc(Mid$(s, i, 1)) Then Exit Function
Next i
ContainsOnly0 = True
End Function
'Die eigentliche Arbeit findet in folgender Prozedur statt:
Private Static Sub ReplaceBin(ByRef Result As String, _
ByRef Text As String, ByRef Search As String, _
ByRef strOld As String, ByRef strNew As String, _
ByVal Start As Long, ByVal Count As Long)
Dim TextLen As Long
Dim OldLen As Long
Dim NewLen As Long
Dim ReadPos As Long
Dim WritePos As Long
Dim CopyLen As Long
Dim Buffer As String
Dim BufferLen As Long
Dim BufferPosNew As Long
Dim BufferPosNext As Long
'Ersten Treffer bestimmen:
If Start < 2 Then
Start = InStrB(Search, strOld)
Else
Start = InStrB(Start + Start - 1, Search, strOld)
End If
If Start Then
OldLen = LenB(strOld)
NewLen = LenB(strNew)
Select Case NewLen
'einfaches Überschreiben:
Case OldLen
Result = Text
For Count = 1 To Count
MidB$(Result, Start) = strNew
Start = InStrB(Start + OldLen, Search, strOld)
If Start = 0 Then Exit Sub
Next Count
Exit Sub
'Ergebnis wird kürzer:
Case Is < OldLen
'Buffer initialisieren:
TextLen = LenB(Text)
If TextLen > BufferLen Then
Buffer = Text
BufferLen = TextLen
End If
'Ersetzen:
ReadPos = 1
WritePos = 1
If NewLen Then
'Einzufügenden Text beachten:
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
BufferPosNew = WritePos + CopyLen
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
MidB$(Buffer, BufferPosNew) = strNew
WritePos = BufferPosNew + NewLen
Else
MidB$(Buffer, WritePos) = strNew
WritePos = WritePos + NewLen
End If
ReadPos = Start + OldLen
Start = InStrB(ReadPos, Search, strOld)
If Start = 0 Then Exit For
Next Count
Else
'Einzufügenden Text ignorieren (weil leer):
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
WritePos = WritePos + CopyLen
End If
ReadPos = Start + OldLen
Start = InStrB(ReadPos, Search, strOld)
If Start = 0 Then Exit For
Next Count
End If
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
Result = LeftB$(Buffer, WritePos - 1)
Else
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
Result = LeftB$(Buffer, WritePos + LenB(Text) - ReadPos)
End If
Exit Sub
'Ergebnis wird länger:
Case Else
'Buffer initialisieren:
TextLen = LenB(Text)
BufferPosNew = TextLen + NewLen
If BufferPosNew > BufferLen Then
Buffer = Space$(BufferPosNew)
BufferLen = LenB(Buffer)
End If
'Ersetzung:
ReadPos = 1
WritePos = 1
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
'Positionen berechnen:
BufferPosNew = WritePos + CopyLen
BufferPosNext = BufferPosNew + NewLen
'Ggf. Buffer vergrößern:
If BufferPosNext > BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = LenB(Buffer)
End If
'String "patchen":
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
MidB$(Buffer, BufferPosNew) = strNew
Else
'Position bestimmen:
BufferPosNext = WritePos + NewLen
'Ggf. Buffer vergrößern:
If BufferPosNext > BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = LenB(Buffer)
End If
'String "patchen":
MidB$(Buffer, WritePos) = strNew
End If
WritePos = BufferPosNext
ReadPos = Start + OldLen
Start = InStrB(ReadPos, Search, strOld)
If Start = 0 Then Exit For
Next Count
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
Result = LeftB$(Buffer, WritePos - 1)
Else
BufferPosNext = WritePos + TextLen - ReadPos
If BufferPosNext < BufferLen Then
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
Result = LeftB$(Buffer, BufferPosNext)
Else
Result = LeftB$(Buffer, WritePos - 1) & MidB$(Text, ReadPos)
End If
End If
Exit Sub
End Select
'Kein Treffer:
Else
Result = Text
End If
End Sub
'Die gleiche Routine nochmal, allerdings mit den etwas langsameren String-Funktionen (d. h. Len statt LenB, InStr statt InStrB u.ä.):
Private Static Sub ReplaceBin0(ByRef Result As String, _
ByRef Text As String, ByRef Search As String, _
ByRef strOld As String, ByRef strNew As String, _
ByVal Start As Long, ByVal Count As Long)
Dim TextLen As Long
Dim OldLen As Long
Dim NewLen As Long
Dim ReadPos As Long
Dim WritePos As Long
Dim CopyLen As Long
Dim Buffer As String
Dim BufferLen As Long
Dim BufferPosNew As Long
Dim BufferPosNext As Long
'Ersten Treffer bestimmen:
If Start < 2 Then
Start = InStr(Search, strOld)
Else
Start = InStr(Start, Search, strOld)
End If
If Start Then
OldLen = Len(strOld)
NewLen = Len(strNew)
Select Case NewLen
'einfaches Überschreiben:
Case OldLen
Result = Text
For Count = 1 To Count
Mid$(Result, Start) = strNew
Start = InStr(Start + OldLen, Search, strOld)
If Start = 0 Then Exit Sub
Next Count
Exit Sub
'Ergebnis wird kürzer:
Case Is < OldLen
'Buffer initialisieren:
TextLen = Len(Text)
If TextLen > BufferLen Then
Buffer = Text
BufferLen = TextLen
End If
'Ersetzen:
ReadPos = 1
WritePos = 1
If NewLen Then
'Einzufügenden Text beachten:
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
BufferPosNew = WritePos + CopyLen
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen)
Mid$(Buffer, BufferPosNew) = strNew
WritePos = BufferPosNew + NewLen
Else
Mid$(Buffer, WritePos) = strNew
WritePos = WritePos + NewLen
End If
ReadPos = Start + OldLen
Start = InStr(ReadPos, Search, strOld)
If Start = 0 Then Exit For
Next Count
Else
'Einzufügenden Text ignorieren (weil leer):
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen)
WritePos = WritePos + CopyLen
End If
ReadPos = Start + OldLen
Start = InStr(ReadPos, Search, strOld)
If Start = 0 Then Exit For
Next Count
End If
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
Result = Left$(Buffer, WritePos - 1)
Else
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos)
Result = Left$(Buffer, WritePos + Len(Text) - ReadPos)
End If
Exit Sub
'Ergebnis wird länger:
Case Else
'Buffer initialisieren:
TextLen = Len(Text)
BufferPosNew = TextLen + NewLen
If BufferPosNew > BufferLen Then
Buffer = Space$(BufferPosNew)
BufferLen = Len(Buffer)
End If
'Ersetzung:
ReadPos = 1
WritePos = 1
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
'Positionen berechnen:
BufferPosNew = WritePos + CopyLen
BufferPosNext = BufferPosNew + NewLen
'Ggf. Buffer vergrößern:
If BufferPosNext > BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = Len(Buffer)
End If
'String "patchen":
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen)
Mid$(Buffer, BufferPosNew) = strNew
Else
'Position bestimmen:
BufferPosNext = WritePos + NewLen
'Ggf. Buffer vergrößern:
If BufferPosNext > BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = Len(Buffer)
End If
'String "patchen":
Mid$(Buffer, WritePos) = strNew
End If
WritePos = BufferPosNext
ReadPos = Start + OldLen
Start = InStr(ReadPos, Search, strOld)
If Start = 0 Then Exit For
Next Count
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
Result = Left$(Buffer, WritePos - 1)
Else
BufferPosNext = WritePos + TextLen - ReadPos
If BufferPosNext < BufferLen Then
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos)
Result = Left$(Buffer, BufferPosNext)
Else
Result = Left$(Buffer, WritePos - 1) & Mid$(Text, ReadPos)
End If
End If
Exit Sub
End Select
'Kein Treffer:
Else
Result = Text
End If
End Sub
© VBA für Excel: String ersetzen mit Replace-Funktion wurde dokumentiert von Winfried Brumma (Pressenet), 2020. Bildnachweis: Notebook Tastatur, CC0 (Public Domain Lizenz).
Archive:
Jahrgänge:
2022 |
2021 |
2020 |
2019 |
2018 |
2017 |
2016 |
2015 |
2014 |
2013 |
2012 |
2011 |
2010 |
2009
Themen:
Autor werden |
Buch-Rezensionen |
Ratgeber |
Sagen & Legenden |
Fantasy Mythologie |
IT & Technik |
Krimi Thriller |
Fachartikel & Essays |
Jugend- & Kinderbücher |
Bedeutung der Tarotkarten |
Bedeutung der Krafttiere
Noch mehr Bücher lesen (Werbung):
Fantasy & Science Fiction
| Krimis & Thriller
| Ratgeber
| Reise & Abenteuer
Sie schreiben anspruchsvolle Romane und Erzählungen? Wir suchen neue Autorinnen und Autoren. Melden Sie sich!
Wenn Sie die Informationen auf diesen Seiten interessant fanden, freuen wir uns über einen Förderbeitrag. Empfehlen Sie uns auch gerne in Ihren Netzwerken. Herzlichen Dank!
Sitemap Impressum Datenschutz RSS Feed