Hallo,

ich kenne mich in VBA nicht wirklich so gut aus.

Problem: in Excel möchte ich in einem speziellen Bereich mehrere Begriffe (wechselnde) fett markieren innerhalb von Spalten.

Diese Lösung habe ich mit Hilfe des Internets "gebastelt":

Sub Ersetzen()
Dim i As Integer
Dim k As Integer
Dim Laenge As Integer
Dim intAnz As Integer

Dim rngC As Range
Dim strSuch As String
Dim strErsetz As String
Dim myRange As Range

Dim intAnz2 As Integer
Dim rngC2 As Range
Dim strSuch2 As String
Dim strErsetz2 As String
Dim Laenge2 As Integer




Such:
strSuch = Application.InputBox("Bitte das 1. gesuchte Wort eingeben", _
"Suchwort", Type:=2)
strSuch2 = Application.InputBox("Bitte das 2. gesuchte Wort eingeben", _
"Suchwort2", Type:=2)

If strSuch = "" Or strSuch = "Falsch" Then
MsgBox "Bitte Suchwort eingeben"
GoTo Such
End If
If strSuch2 = "" Or strSuch2 = "Falsch" Then
MsgBox "Bitte 2. Suchwort eingeben"
GoTo Such
End If

Ersatz:
strErsetz = Application.InputBox("Bitte das Ersatzwort eingeben", _
"Ersatzwort", Type:=2)
strErsetz2 = Application.InputBox("Bitte das 2. Ersatzwort eingeben", _
"Ersatzwort2", Type:=2)
If strErsetz = "" Or strErsetz = "Falsch" Then
MsgBox "Bitte Ersatzwort eingeben"
GoTo Ersatz
End If
If strErsetz2 = "" Or strErsetz2 = "Falsch" Then
MsgBox "Bitte 2. Ersatzwort eingeben"
GoTo Ersatz
End If

Set myRange = Application.InputBox("Bitte den zu durchsuchenden" _
& "Bereich markieren", "Bereich", Default:="A1", Type:=8)
If myRange Is Nothing Then
MsgBox "Bitte Bereich markieren"
Exit Sub
End If

Laenge = Len(strErsetz)
Laenge2 = Len(strErsetz2)

For Each rngC In myRange
i = 0
rngC = Replace(rngC, strSuch, strErsetz)

intAnz = (Len(rngC) - Len(Replace(rngC, strErsetz, ""))) / Laenge


If intAnz > 0 Then
For k = 1 To intAnz
i = InStr(1 + i, rngC, strErsetz)
rngC.Characters(i, Laenge).Font.Bold = True
Next k
End If

Next rngC

For Each rngC2 In myRange
i = 0
rngC2 = Replace(rngC2, strSuch2, strErsetz2)
intAnz2 = (Len(rngC2) - Len(Replace(rngC2, strErsetz2, ""))) / Laenge2

If intAnz2 > 0 Then
For k = 1 To intAnz2
i = InStr(1 + i, rngC2, strErsetz2)
rngC2.Characters(i, Laenge2).Font.Bold = True
Next k
End If

Next rngC2


End Sub

Leider wird bei der Fettmarkierung des zweiten Wortes die Fettmarkierung des ersten Wortes aufgehoben. Ich bräuchte aber die "automatische" Markierung von bis zu 3 Wörtern...

Kann mir jemand helfen?

Danke und Gruß,

Susanne