Option Explicit

Public Type tReplace
  Find As String
  Replace As String
End Type

Public Sub Testlauf()
  
  '//////////////////////////////
  '// Suchen/Ersetzen definieren
  '//////////////////////////////
  
  Dim t(1 To 2) As tReplace
  Dim rngSel    As Excel.Range
  Dim i         As Long
  
  For i = LBound(t) To UBound(t)
    Do 'Zwangsangabe
      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 'Zwangsangabe
      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 'Zwangsangabe
      Set rngSel = Application.InputBox("Bereich auswählen:", "Bereich auswählen", Type:=8)
    Loop While rngSel Is Nothing
  On Error GoTo 0
  
  '//////////////////////////////
  '// Suchen/Ersetzen/Formatieren
  '// ausführen
  '//////////////////////////////
  
  Dim rngData As Excel.Range
  Dim rngRet  As Excel.Range
  Dim strFA   As String
  
  ' Suchen (Zellen ermitteln, die relevant sind)
  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
  
  'wenn keine relevanten Zellen gefunden -> Ende
  If rngData Is Nothing Then
    
    ' Info an Nutzer
    MsgBox "Keine Treffer.", vbInformation
    
  Else
    
    ' Ersetzen (in den relevanten Zellen die entspr. Inhalte ersetzen)
    For i = LBound(t) To UBound(t)
      rngData.Replace t(i).Find, t(i).Replace, LookAt:=xlPart, _
                        SearchOrder:=xlByColumns, _
                        MatchCase:=True, MatchByte:=False
    Next
    
    ' Formatierung
    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
    
    ' Info an Nutzer
    MsgBox "Der Inhalt von " & rngData.Cells.Count & " Zellen wurde angepasst.", vbInformation
    
  End If
  
  ' Aufräumen
  Set rngRet = Nothing
  Set rngData = Nothing
  Set rngSel = Nothing
  
End Sub

Gruß, Trägheit