Sub Ersetze()
Dim oFinde As Range, WSh As Worksheet
Dim sSuch1 As String, sSuch2 As String, sErsetz As String
Dim sErsteAdresse As String
sSuch1 = "Apfel": sSuch2 = "Birne": sErsetz = "Apfelkuchen"
Set WSh = Sheets("Tabelle2")
Set oFinde = WSh.UsedRange.Find(sSuch1, LookIn:=xlValues)
If Not oFinde Is Nothing Then
sErsteAdresse = oFinde.Address
Do
Set oFinde = WSh.UsedRange.FindNext(oFinde)
If oFinde Is Nothing Then Exit Do
If oFinde.value Like "*" & sSuch2 & "*" Then
oFinde.value = Replace(oFinde.value, sSuch1, sErsetz)
End If
Loop While Not oFinde Is Nothing And oFinde.Address <> sErsteAdresse
End If
End Sub