Suchen und Ersetzen mit VBA

Marc · 2020-07-09T11:48:42+00:00

Hallo liebe Excel und VBA-Freunde, ich bin ein DAU in VBA, aber da ich nach einer besseren Funktion als die "suchen und ersetzen" Funktion von Excel gesucht habe. Denn dann wird die Formatierung einzelner Wörter nicht übernommen und anstelle, dass ich nur 1 Wort ändern muss, müsste ich dann 4. Ich habe nämliche ca. 200 Zellen in den ich mehr als 255 Zeichen habe und viele Wörter innerhalb der Zellen sind redundant. Nun habe ich dieses Script gefunden: Sub CharactersReplace(Rng As Range, FindText As String, ReplaceText As String, Optional _ MatchCase As Boolean = False) 'UpdatebyExtendoffice20160711 Dim I As Long Dim xLenFind As Long Dim xLenRep As Long Dim K As Long Dim xValue As String Dim M As Long Dim xCell As Range xLenFind = Len(FindText) xLenRep = Len(ReplaceText) If Not MatchCase Then M = 1 For Each xCell In Rng If VarType(xCell) = vbString Then xValue = xCell.Value K = 0 For I = 1 To Len(xValue) If StrComp(Mid$(xValue, I, xLenFind), FindText, M) = 0 Then xCell.Characters(I + K, xLenFind).Insert ReplaceText K = K + xLenRep - xLenFind End If Next End If Next End Sub Sub Test_CharactersReplace() Dim xRg As Range Dim xTxt As String Dim xCell As Range On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("Select a range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub Call CharactersReplace(xRg, "Ersetze das Wort", "Gegen das Wort", True) End Sub Das Skript funktioniert... aber leider nur mit Zellen weniger als 255 Zeichen... Jetzt habe ich allerhand gelesen wegen eines Umweges mit Arrys und so weiter. Aber als DAU kann ich leider das nicht integrieren, geschweige, dass ich coden könnte. Könnt ihr mich dahingehend unterstützen? Vielen Dank und Beste Grüße Marc St.

Hallo Marc
Anbei noch eine kleine Verbesserung bzgl. Performance (wenn nur wenige Formatierungen im Text dann cCharRange höher setzen)


Sub CharactersReplace(Rng As Range, FindText As String, ReplaceText As String, _
Optional MatchCase As Boolean = False)
'UpdatebyExtendoffice20160711
Const cCharRange = 10
Dim daten As Variant, neutext As Variant
Dim xLenFind As Long, xLenRep As Long, xLenText As Long
Dim i As Long, j As Long, k As Long, stellen As Long, position As Long
Dim xCell As Range
Dim austext As String
Dim altzustand
Dim foundItalic As Boolean
Dim foundBold As Boolean
altzustand = Application.ScreenUpdating
Application.ScreenUpdating = False
xLenFind = Len(FindText)
xLenRep = Len(ReplaceText)
Debug.Print Time, "Start"
For Each xCell In Rng
If VarType(xCell) = vbString Then
austext = xCell
xLenText = Len(austext)
'Daten auslesen
ReDim daten(1 To xLenText + 1, 1 To 2)   'Zeichenanzahl, Format
ReDim neutext(1 To xLenText)
For i = 1 To xLenText
neutext(i) = Mid(austext, i, 1)
daten(i, 1) = 1
j = 0
If (i Mod cCharRange = 1) Then
' liefert
' False (keine Formatierung)
' True(alles formatiert),
' Null (teilweise formatiert)
foundItalic = IsNull(xCell.Characters(Start:=i, Length:=cCharRange).Font. _
Italic)
If Not foundItalic Then
foundItalic = xCell.Characters(Start:=i, Length:=10).Font.Italic
End If
foundBold = IsNull(xCell.Characters(Start:=i, Length:=cCharRange).Font.Bold) _
If Not foundBold Then
foundBold = xCell.Characters(Start:=i, Length:=10).Font.Bold
End If
End If
If foundItalic Then
If xCell.Characters(Start:=i, Length:=1).Font.Italic = True Then j = j + 1 ' _
Kursiv
End If
If foundBold Then
If xCell.Characters(Start:=i, Length:=1).Font.Bold = True Then j = j + 2   ' _
Fett
End If
daten(i, 2) = j
Next
'Daten ersetzen
position = InStr(1, austext, FindText, vbTextCompare)
If position = 0 Then GoTo weiter
While position > 0
neutext(position) = ReplaceText
daten(position, 1) = xLenRep
For j = position + 1 To position + xLenFind - 1
daten(j, 1) = ""
neutext(j) = ""
Next
position = InStr(position + xLenFind, austext, FindText, vbTextCompare)
Wend
'Daten zurückschreiben
xCell = Join(neutext, "")
xCell.Characters.Font.Bold = False
xCell.Characters.Font.Italic = False
k = daten(1, 2)
position = 1
stellen = 0
For i = 1 To xLenText + 1
If k = daten(i, 2) Then
If daten(i, 1)  "" Then
stellen = stellen + daten(i, 1)
End If
Else
'formatieren
If k = 1 Or k = 3 Then
'kursiv machen
xCell.Characters(Start:=position, Length:=stellen).Font.Italic = True
End If
If k = 2 Or k = 3 Then
'fett machen
xCell.Characters(Start:=position, Length:=stellen).Font.Bold = True
End If
k = daten(i, 2)
position = position + stellen
stellen = daten(i, 1)
End If
Next
End If
weiter:
Next
Application.ScreenUpdating = altzustand
Debug.Print Time, "Ende"
End Sub

Moin!
Hier nochmal geändert. Wobei ich das bei meinen Testläufen nicht reproduzieren kann. Falls der Fehler noch da ist, wenn möglich mal eine Datei oder so ein paar Teststrings hochladen.
Bei der Performance habe ich schon versucht so viel wie möglich auf Zugriffe auf die Zellen zu vermeiden. Ist beim Auslesen / Setzen der Formatierung aber notwendig (wobei ich das da auch schon beim Neuformatieren gerafft habt). Auf Grund dessen dauert es da ein wenig. Wenn der Suchstring nicht vorkommt, überpsringe ich jetzt sämtlichen Code. Mehr lässt sich jetzt auf die schnelle wohl nicht verbessern. Bitte mal testen.

Sub CharactersReplace(Rng As Range, FindText As String, ReplaceText As String, Optional _
MatchCase As Boolean = False)
'UpdatebyExtendoffice20160711
Dim daten As Variant, neutext As Variant
Dim xLenFind As Long, xLenRep As Long, xLenText As Long
Dim i As Long, j As Long, k As Long, stellen As Long, position As Long
Dim xCell As Range
Dim austext As String
Dim altzustand
altzustand = Application.ScreenUpdating
Application.ScreenUpdating = False
xLenFind = Len(FindText)
xLenRep = Len(ReplaceText)
For Each xCell In Rng
If VarType(xCell) = vbString Then
austext = xCell.Value
position = InStr(1, austext, FindText, vbTextCompare)
If position = 0 Then GoTo weiter
xLenText = Len(austext)
'Daten auslesen
ReDim daten(1 To xLenText + 1, 1 To 2)   'Zeichenanzahl, Format
ReDim neutext(1 To xLenText)
For i = 1 To xLenText
neutext(i) = Mid(austext, i, 1)
daten(i, 1) = 1
j = 0
If xCell.Characters(Start:=i, Length:=1).Font.Italic = True Then j = j + 1        ' _
Kursiv
If xCell.Characters(Start:=i, Length:=1).Font.Bold = True Then j = j + 2             _
'Fett
daten(i, 2) = j
Next
'Daten ersetzen
While position > 0
neutext(position) = ReplaceText
daten(position, 1) = xLenRep
For j = position + 1 To position + xLenFind - 1
daten(j, 1) = ""
neutext(j) = ""
Next
position = InStr(position + xLenFind, austext, FindText, vbTextCompare)
Wend
'Daten zurückschreiben
xCell = Join(neutext, "")
xCell.Characters.Font.Bold = False
xCell.Characters.Font.Italic = False
k = daten(1, 2)
position = 1
For i = 1 To xLenText + 1
If k = daten(i, 2) Then
If daten(i, 1)  "" Then
stellen = stellen + daten(i, 1)
End If
Else
'formatieren
If k = 1 Or k = 3 Then
'kursiv machen
xCell.Characters(Start:=position, Length:=stellen).Font.Italic = True
End If
If k = 2 Or k = 3 Then
'fett machen
xCell.Characters(Start:=position, Length:=stellen).Font.Bold = True
End If
k = daten(i, 2)
position = position + stellen
stellen = daten(i, 1)
End If
Next
End If
weiter:
Erase daten
Erase neutext
Next
Application.ScreenUpdating = altzustand
End Sub

Forumthread: Suchen und Ersetzen mit VBA

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial