Option Explicit
Public Type tReplace
Find As String
Replace As String
End Type
Public Sub Testlauf()
Dim t(1 To 2) As tReplace
Dim rngSel As Excel.Range
Dim i As Long
For i = LBound(t) To UBound(t)
Do
t(i).Find = Application.InputBox(i & ". Suchwort eingeben:", "Suchwort " & i, Type:=2)
Loop While t(i).Find = "" Or t(i).Find = CStr(False)
Next
For i = LBound(t) To UBound(t)
Do
t(i).Replace = Application.InputBox(i & ". Ersatzwort eingeben:", "Suchwort " & i, Type:=2)
Loop While t(i).Replace = "" Or t(i).Replace = CStr(False)
Next
On Error Resume Next
Do
Set rngSel = Application.InputBox("Bereich auswählen:", "Bereich auswählen", Type:=8)
Loop While rngSel Is Nothing
On Error GoTo 0
Dim rngData As Excel.Range
Dim rngRet As Excel.Range
Dim strFA As String
For i = LBound(t) To UBound(t)
Set rngRet = rngSel.Find(t(i).Find, LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=True, MatchByte:=False)
If Not rngRet Is Nothing Then
strFA = rngRet.Address
Do
If Not rngData Is Nothing Then
Set rngData = Union(rngRet, rngData)
Else
Set rngData = rngRet
End If
Set rngRet = rngSel.FindNext(rngRet)
Loop While rngRet.Address <> strFA
End If
Next
If rngData Is Nothing Then
MsgBox "Keine Treffer.", vbInformation
Else
For i = LBound(t) To UBound(t)
rngData.Replace t(i).Find, t(i).Replace, LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=True, MatchByte:=False
Next
Dim rngCell As Excel.Range
Dim k As Long
For Each rngCell In rngData.Cells
For i = LBound(t) To UBound(t)
k = InStr(1, rngCell.Text, t(i).Replace, vbBinaryCompare)
Do
rngCell.Characters(k, Len(t(i).Replace)).Font.Bold = True
k = InStr(k + 1, rngCell.Text, t(i).Replace, vbBinaryCompare)
Loop While k > 0
Next
Next
MsgBox "Der Inhalt von " & rngData.Cells.Count & " Zellen wurde angepasst.", vbInformation
End If
Set rngRet = Nothing
Set rngData = Nothing
Set rngSel = Nothing
End Sub