Option Explicit
Sub Zahlen_quartette_ersetzen()
Const strReplace As String = " Ersatz "
Dim strInhalt As String
Dim lngLaufZahl As Long
Dim lngStart As Long
Dim lngEnde As Long
strInhalt = ActiveCell
lngStart = 1
lngEnde = Len(strInhalt) - 4
Do
For lngLaufZahl = lngStart To lngEnde
If IsNumeric(Mid(strInhalt, lngLaufZahl, 4)) Then
strInhalt = Left(strInhalt, lngLaufZahl - 1) & strReplace & Right(strInhalt, Len(strInhalt) - lngLaufZahl - 3)
lngStart = lngLaufZahl + Len(strReplace)
lngEnde = Len(strInhalt) - 3
Exit For
End If
Next lngLaufZahl
If lngStart > lngEnde - 3 Then Exit Do
If lngLaufZahl >= lngEnde Then Exit Do
Loop
ActiveCell = strInhalt
End Sub