Guten Morgen!
Also hier meine Variante. Wieder mit Kommentaren (ist aber mehr grün als neue Codezeilen geworden :-) ). Falls du auch eine Version brauchst, wo die packagenamen in Blatt1 der Ausgangsdatei auch zeilenunabhängig stehen (also nicht nur in Ziel 75 bis 79) mal melden. Ansonsten kannst du bei einlesen der parameter, wo i mit der zeilennummer verglichen wird anpassen. Derzeit 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
' wenn zwischen A 75 bis 79 was steht dann in der else schleife die packages prüfen
If i < 75 And i > 79 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
Else
'jetzt sind wir im Bereich der packages in Blatt 1
'nur wenn rechts davon nein steht, die parameter prüfen
If Workbooks(ziel).Worksheets(1).Cells(i, 2) = "nein" Then
'jetzt mal alles packages in Blatt 2 prüfen
For k = 1 To ende2
'packagename in Blatt1 ist identisch mit dem in der Zelle in Blatt 2
If Workbooks(ziel).Worksheets(1).Cells(i, 1) = Workbooks(ziel).Worksheets(2).Cells(k, 1) Then
'Anzahl der parameter in zeile 7 um ein erhöhenb
parameter(7, 0) = parameter(7, 0) + 1
'da wir aus Blatt 2 lesen könnten es ggf. mehr parameter als in der Dimensionierung sein, deshalb mal prüfen ob es noch passt
' wenn nicht, dann die Dimension von parameter unter Beibehaltung der Einträge erhöhen.
If ende1 < parameter(7, 0) Then ReDim Preserve parameter(8, parameter(7, 0))
'Wert für den parameter zuweisen, wenn er nicht leer ist
If Workbooks(ziel).Worksheets(2).Cells(i, 2) <> "" Then parameter(7, parameter(7, 0)) = Workbooks(ziel).Worksheets(2).Cells(i, 2)
End If
Next k
End If 'prüfung auf nein bei packages
End If ' prüfung für bereich der package
End If 'Prüfung leer
Next i
'datei öffnen
Workbooks.Open Filename:=pfad & quelle
'schauen wieviele Zellen beschrieben sind, gesucht wird in Spalte A, C und D
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)
For k = 1 To zeilen
loschen(k) = 0
Next k
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
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
|