Hallo Christy!
Erstmal gute Besserung. Habe mal den Code verändert. Zumindest bei mir macht er das gewünschte. :-) Schau mal bitte ob es bei dir auch läuft. UNd nochmals Entschuldigung für den Fehler letztens. Weiß nicht genau warum ich das drin hatte, war aber falsch. Gruß und schonmal einen guten Rutsch.
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 zeilen()
Dim letzter
Application.ScreenUpdating = False
ReDim zeilen(0)
zeilen(0) = 0
ziel = ThisWorkbook.Name
pfad = "C:\Users\ich\Desktop\Programmieung\hallo\Neuer Ordner" 'noch anpassen
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
quelle = "Datei2.xls" 'mit 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 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 'Code ausführung
Application.ScreenUpdating = True
End Sub
|