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 zeilen()
Dim letzter
Application.ScreenUpdating = False
ReDim zeilen(0)
zeilen(0) = 0
ziel = ThisWorkbook.Name
pfad = "C:\Users\ich\Desktop\Programmieung\hallo\Neuer Ordner"
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
quelle = "Datei2.xls"
If ActiveSheet.Cells(1, 1) <> "" Then
anzparameter = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Workbooks.Open Filename:=pfad & quelle
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(3)
Set ergebnis = .Find(suche, LookIn:=xlValues)
If Not ergebnis Is Nothing Then
letzter = Application.WorksheetFunction.CountIf(Workbooks(quelle).Worksheets(1).Columns(3), "*" & suche & "*")
For j = 1 To letzter
If ersetz = "" Then
zeilen(0) = zeilen(0) + 1
ReDim Preserve zeilen(zeilen(0))
zeilen(zeilen(0)) = ergebnis.Row
Else
Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, 3) = Replace(Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, 3), suche, ersetz)
End If
Set ergebnis = .FindNext(ergebnis)
Next j
End If
For j = zeilen(0) To 1 Step -1
Workbooks(quelle).Worksheets(1).Rows(zeilen(j)).Delete
Next j
ReDim zeilen(0)
zeilen(0) = 0
End With
Set ergebnis = Nothing
End If
Next i
Application.CutCopyMode = False
Workbooks(ziel).Activate
Workbooks(quelle).Close savechanges:=True
End If
Application.ScreenUpdating = True
End Sub