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
|