So, dann bin ich wieder. Unten jetzt mal der Code, wie ich ihn vorhin mal grob skizziert hatte. Habe jetzt mal ein paar Kommentare mehr reingemacht - insb. auch bei den Variablen am Anfang. Die Teile zuviel (Ziel und pfad wurden auch an 2 Stellen benannt - was für nen Murks ne) habe ich (hoffentlich alle :-) ) entfernt. Das array loschen ist wieder vom Typ Byte , die Zeile mit dem Überlauf dafür raus -. sollte also passen. Für die neuen Parameter schaue ich ob ein x (klein) oder X (groß) drin stehen - beides wird akzeptiert - sonst mal ändern. Zwei Sachen noch.
Die Parameter auf Blatt 1 und 2 sind die eigentlich eindeutig? Also wenn es bspw. die Werte Zeile2 und Zeile22 gibt, findet der Code Zeile22 nur wenn er auch drin steht. Bei Zeile2 aber aber sowohl Werte mit Zeile2 als auch Zeile22 - da ist ja Zeile2 ein Teil von. So wie beschrieben ist bei pBUKRS ja eine Führungsnull bei den einstelligen Werten, dass passt. Wenn das bei den anderen nicht so ist und die ineinander vorkommen würden, müssten wir ggf. nochmal was ändern.
Und da du die Datei2 hast, wie ist es mit der Laufzeit? Es würde ggf. noch potential zum Beschleunigen geben. Bei k = 2 und k =3 (die 4 speziellen und die restlichen von Blatt 1) ersetzen wir ja nur, dass könnte man ggf. ohne die mühsame Suche mit .find machen. Weiß jetzt nicht ob das viel ausmachen würde, wäre aber eine Möglichkeit.
Also jetzt der Code - falls du selber getestet hast, kanst du ja vergleichen. Habe diesmal meinen Pfad draußen und das x an xlsx schon dran. :-) Zudem muss das nur einmal geändert werden, ganz am Anfang nach den Deklarationen der Variablen. So schönen Abend noch. Gruß
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 i As Long 'Variable zu zählen
Dim j As Long 'Variable zu zählen
Dim l As Long 'Variable zu zählen
Dim k As Long 'Variable zu zählen
Dim letzter 'Anzahl der Vorkommen der parameter
Dim temp As String 'nimmt kurzzeitig die Parameter von Blatt 1 auf
Dim zeilen As Long 'die Anzahl der Zeile in denen gelöscht wird
Dim parameter() As String ' nimmt alle Parameter + Werte dazu auf
Dim spalte As Long ' die Spalte wo gesuch wird
Dim loschen() As Byte ' Array für die Zeilen, hier wird mit 1 eingetragen, wenn gelöscht werden soll
Dim ende1 As Integer ' Zeile der letzten Eintragungen Blatt 1
Dim ende2 As Integer ' Zeile der letzten Eintragungen Blatt 1
'Änderungen nicht sichtbar machen - Bildschirm einfrieren
Application.ScreenUpdating = False
'Pfade Namen etc. festlegen
ziel = ThisWorkbook.Name
pfad = " " 'noch anpassen
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
quelle = "Datei2.xlsx" 'x
'letzte gefüllte Zeile in Spalte A auf Blatt 1 und 2
ende1 = Workbooks(ziel).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ende2 = Workbooks(ziel).Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
'parameter dimensionieren, jetzt mit 8 zeilen
ReDim parameter(8, ende1)
parameter(1, 0) = 0
parameter(3, 0) = 0
parameter(5, 0) = 4
parameter(7, 0) = 0
'parameter aus blatt 1 auslesen
For i = 1 To ende1
If Workbooks(ziel).Worksheets(1).Cells(i, 1) <> "" Then
'Parameternamen auswerten
temp = Workbooks(ziel).Worksheets(1).Cells(i, 1)
If Len(temp) <> Len(Replace(temp, "pBUKRS", "")) Then
'ein Parameter der Sorte pBUKRS%%
parameter(1, 0) = parameter(1, 0) + 1
parameter(1, parameter(1, 0)) = Workbooks(ziel).Worksheets(1).Cells(i, 1)
parameter(2, parameter(1, 0)) = Workbooks(ziel).Worksheets(1).Cells(i, 5)
Else
Select Case temp
Case "pBUDATto"
parameter(5, 1) = "pBUDATto"
parameter(6, 1) = Workbooks(ziel).Worksheets(1).Cells(i, 5)
Case "pUDATEto"
parameter(5, 2) = "pUDATEto"
parameter(6, 2) = Workbooks(ziel).Worksheets(1).Cells(i, 5)
Case "pZALDTto"
parameter(5, 3) = "pZALDTto"
parameter(6, 3) = Workbooks(ziel).Worksheets(1).Cells(i, 5)
Case "pWADAT_ISTto"
parameter(5, 4) = "pWADAT_ISTto"
parameter(6, 4) = Workbooks(ziel).Worksheets(1).Cells(i, 5)
Case ""
'leer sollte eigentlich nix mehr sein, aber man weiß ja nie
Case Else
'die mit dem gleiche aufbau hatten wir schon, die 4 speziellen auch, bleiben nur die anderen
parameter(3, 0) = parameter(3, 0) + 1
parameter(3, parameter(3, 0)) = Workbooks(ziel).Worksheets(1).Cells(i, 1)
parameter(4, parameter(3, 0)) = Workbooks(ziel).Worksheets(1).Cells(i, 5)
End Select
End If
End If
Next i
'prüfen ob das parameter array bei Blatt 2 noch passen würde ansonsten anpassen
If ende1 < ende2 Then ReDim Preserve parameter(8, ende2)
'parameter blatt 2 auslesen, aber nur die wo das x steht
For i = 1 To ende2
If Workbooks(ziel).Worksheets(2).Cells(i, 1) <> "" Then
If Workbooks(ziel).Worksheets(2).Cells(i, 3) = "x" Or Workbooks(ziel).Worksheets(2).Cells(i, 3) = "X" Then
parameter(7, 0) = parameter(7, 0) + 1
parameter(7, parameter(7, 0)) = Workbooks(ziel).Worksheets(2).Cells(i, 1)
'da wir hier nur löschen wollen und nur die parameter vom löschen ausgelesen haben,
'brauchen wir in Zeile 8 nix eintragen, ist aber wegen dem Code unten mit im Aufbau drin geblieben
End If
End If
Next i
'datei öffnen
Workbooks.Open Filename:=pfad & quelle
'schauen wieviele Zellen beschrieben sind, gesucht wird in Spalte C, D und A
zeilen = Workbooks(quelle).Worksheets(1).Cells(Rows.Count, 3).End(xlUp).Row
If zeilen < Workbooks(quelle).Worksheets(1).Cells(Rows.Count, 4).End(xlUp).Row Then zeilen = Workbooks(quelle).Worksheets(1).Cells(Rows.Count, 4).End(xlUp).Row
If zeilen < Workbooks(quelle).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row Then zeilen = Workbooks(quelle).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'loschen dimensionieren
ReDim loschen(zeilen)
'vorsichtshalber alle Werte mal auf 0 setzen, die zum Löschen werden später auf 1 gesetzt
For k = 1 To zeilen
loschen(k) = 0
Next k
'für alle Parameter arten, sind 4 Stück
For k = 1 To 4
'festlegen wo gesucht wird
If k = 1 Or k = 2 Then
spalte = 3
ElseIf k = 3 Then
spalte = 4
Else
'bei k = 4
spalte = 1
End If
For l = parameter(2 * k - 1, 0) To 1 Step -1
'Namen der parameter holen
suche = parameter(2 * k - 1, l)
If suche <> "" Then
'Wert zum ersetzen holen
ersetz = parameter(2 * k, l)
With Workbooks(quelle).Worksheets(1).Columns(spalte)
'suchen de Parameternamen
Set ergebnis = .Find(suche, LookIn:=xlValues)
If Not ergebnis Is Nothing Then
'wenn was gefunden, suchen wie oft das in der Spalte vorkommt
letzter = Application.WorksheetFunction.CountIf(Workbooks(quelle).Worksheets(1).Columns(spalte), "*" & suche & "*")
For j = 1 To letzter
If (ersetz = "" And k = 1) Or k = 4 Then
' löschen nur bei k =1 und k = 4
loschen(ergebnis.Row) = 1
Else
' Werte ersetzen
Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, spalte) = Replace(Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, spalte), suche, ersetz)
End If
'nächsten Wert finden
Set ergebnis = .FindNext(ergebnis)
Next j
End If
End With
Set ergebnis = Nothing
End If 'Vergleich ob leer
Next l
Next k
'jetzt löschen, dazu einfach alle Zeilen durchgehen und schauen ob eine 1 steht.
For j = UBound(loschen) To 1 Step -1
If loschen(j) = 1 Then Workbooks(quelle).Worksheets(1).Rows(j).Delete
Next j
Application.CutCopyMode = False
Workbooks(ziel).Activate
'schließeb mit speichern
Workbooks(quelle).Close savechanges:=True
'Änderungen sichtbar machen
Application.ScreenUpdating = True
End Sub
|