Also der Fehler kommt bei den Zahlen an denen vorne mehrfach die selbe Zahl auftaucht. Warum das so ist, kann ich dir leider nicht sagen. Habe den Code mal abgewandelt. Der Text wird vor dem Löschen nochmal durchgegangen und lange Werte eingekürzt. Zudem ist beim Ersetzen eine MsgBox drin. Die gibt an, falls bei der Suchmethode (.find) ein falsches Ergebnis gekommen ist (sollte entweder da passieren oder im Speicher was falsch laufen).  Das Programm sollte jetzt durchlaufen und auch nach dem Ersetzen speichern. FAlls irgendwann ne Nachricht kommt, bräuchte ich die mal. Würde dann ggf. dn COde nochmal ändern bzw. mich auf die Suche machen. Wieder den Pfad ersetzen!

Option Explicit

Sub ersetzen()

Dim ziel As String      'die Datei mit dem Code
Dim quelle As String    'die Datei in der ersetz wird
Dim pfad As String      'Pfad zur Datei in der ersetzt wird
Dim suche As String     'der Text der gesucht wird, PARAMETER
Dim ersetz              ' Wert die dann eingefügt werden , Spalte 3
Dim ergebnis As Object           'Rückgabewert des Ersetzen
Dim anzparameter As Long 'anzahl von versch. Parameter
Dim i As Long              'Variable zu zählen
Dim j As Long
Dim k As Long
Dim zeilen()
Dim letzter
Dim loschen As String
Dim temp As String
Dim loschen2
Dim posdav
Dim posakt
Dim gefunden As Boolean

'Application.ScreenUpdating = False

ReDim zeilen(0)
zeilen(0) = 0
loschen = ""

ziel = ThisWorkbook.Name
pfad = "       "     'noch anpassen
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"

quelle = "Datei2.xlsx"  'x

If ActiveSheet.Cells(1, 1) <> "" Then       'wenn der erste Parameter fehlt nix machen
    anzparameter = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'schauen wieviel Parameter da sind
    Workbooks.Open Filename:=pfad & quelle
    For k = 3 To 4
    For i = anzparameter To 1 Step -1
        suche = Workbooks(ziel).Worksheets(1).Cells(i, 1).Value
        If suche <> "" Then
            
            ersetz = Workbooks(ziel).Worksheets(1).Cells(i, 5).Value
            With Workbooks(quelle).Worksheets(1).Columns(k)
            Set ergebnis = .Find(suche, LookIn:=xlValues)

            If Not ergebnis Is Nothing Then
                letzter = Application.WorksheetFunction.CountIf(Workbooks(quelle).Worksheets(1).Columns(k), "*" & suche & "*")
               
                For j = 1 To letzter
                    If ersetz = "" Then
                            
                            temp = Replace(loschen, ergebnis.Row & ";", "")
                            
                            If Len(temp) = Len(loschen) Then
                            
                                posdav = 1
                                posakt = InStr(posdav, loschen, ";")
                                gefunden = False

                                While posakt <> 0

                                If CLng(Mid(loschen, posdav, posakt - posdav)) > ergebnis.Row Then
   
                                    loschen = Left(loschen, posdav - 1) & ergebnis.Row & ";" & Right(loschen, Len(loschen) - posdav + 1)
    
                                    posakt = 0
                                    gefunden = True
                                Else
   
                                    posdav = posakt + 1
                                    posakt = InStr(posdav, loschen, ";")
                                End If

                                Wend
                                If gefunden = False Then loschen = loschen & ergebnis.Row & ";"

                            End If
  
                    Else
                        loschen = Replace(loschen, ergebnis.Row & ";", "")
                        If Len(ergebnis.Row) > 5 Then MsgBox "Hier kommt der Fehler" & suche & "Ende"
                        Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, k) = Replace(Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, k), suche, ersetz)
                    End If
                    Set ergebnis = .FindNext(ergebnis)
                Next j
                
             End If
   
            End With
            Set ergebnis = Nothing
          
        End If
    Next i
    Next k

     'jetzt löschen
   loschen = "56787672"
     loschen2 = Split(loschen, ";")

     For j = 0 To UBound(loschen2) - 2
     If Len(loschen2(j)) > Len(loschen2(j + 1)) Then loschen2(j) = Right(loschen2(j), Len(loschen2(j + 1)))
     Next j
     If UBound(loschen2) > -1 Then
        If Len(loschen2(0)) > 5 Then loschen2(0) = Right(loschen2(0), 5)
        If UBound(loschen2) > 2 Then
            If Len(loschen2(UBound(loschen2) - 1)) > 5 Then loschen2(UBound(loschen2) - 1) = Right(loschen2(UBound(loschen2) - 1), 5)
        End If
     End If
    
     For j = UBound(loschen2) To 1 Step -1
        
        Workbooks(quelle).Worksheets(1).Rows(loschen2(j - 1)).Delete
     Next j

    Application.CutCopyMode = False
    Workbooks(ziel).Activate

    Workbooks(quelle).Close savechanges:=True
End If 'Code ausführung

Application.ScreenUpdating = True
End Sub