Hallo Christy! Keine Angst, das bekommen wir hin. Keine Fehlermeldung ist doch schon mal was. :-D Er findet also die Zeile richtig und im Speicher verhaspelt er sich dann. Und dann gleich mal Asche auf mein Haupt. Hatte vorhin ne Weile rumgetestet und beim Posten vergessen eine Zeile (die Nr. 99 vorhin) zu löschen. Damit habe ich die Auflistung deiner zu löschenden Zeilen spontan überschrieben. Sorry dafür - sollte eigentlich nicht passieren. Habe das jetzt rausgenommen und unten ist jetzt der laufende Code. Also wenn du da nochmal probieren magst.
Zu der Beschreibung oben (das folgeproblem noch nicht). Ist das das, was der Code bisher schon macht oder hat sich da was geändert. Müsste mich da sonst jetzt erstmal in Rhe einlesen - sind nen Haufen Variablennamen und Bedingungen. :-)
Also hier der Code:
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 & ";", "")
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
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)) > 4 Then loschen2(0) = Right(loschen2(0), 4)
If UBound(loschen2) > 2 Then
If Len(loschen2(UBound(loschen2) - 1)) > 4 Then loschen2(UBound(loschen2) - 1) = Right(loschen2(UBound(loschen2) - 1), 4)
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
|