Option Explicit
Sub ersetzen()
Dim ziel As String
Dim quelle As String
Dim pfad As String
Dim suche As String
Dim ersetz
Dim ergebnis As Object
Dim anzparameter As Long
Dim i As Long
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
ReDim zeilen(0)
zeilen(0) = 0
loschen = ""
ziel = ThisWorkbook.Name
pfad = " "
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
quelle = "Datei2.xlsx"
If ActiveSheet.Cells(1, 1) <> "" Then
anzparameter = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
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
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
Application.ScreenUpdating = True
End Sub