Hallo Christy! Erstmal ein gesundes Neues Jahr. Anbei dann der Code für den Wunsch. Dein Folgeproblem hätte ich auch gleich mit eingebaut, aber da wusste ich nicht wie (nicht im einzelnen, abstrakt reicht eigentlich) die Bezeichnungen in Datei1 Spalte D stehen - insb. wenn mehrer Werte vorkommen. 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
Dim j As Long 'Variable zu zählen
Dim l As Long
Dim k As Long
Dim letzter
Dim temp As String
Dim zeilen As Long
Dim parameter() As String
Dim spalte As Long
Dim loschen() As Byte
Application.ScreenUpdating = False
ziel = ThisWorkbook.Name
pfad = "C:\Users\ich\Desktop\Programmieung\hallo\Neuer Ordner" 'noch anpassen
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
quelle = "Datei2.xls" 'x
ReDim loschen(0)
loschen(0) = 0
ReDim parameter(6, Workbooks(ziel).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
parameter(1, 0) = 0
parameter(3, 0) = 0
parameter(5, 0) = 4
'parameter auslesen
For i = 1 To Workbooks(ziel).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If Workbooks(ziel).Worksheets(1).Cells(i, 1) <> "" Then
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 ""
Case Else
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
'Dateien laden
ziel = ThisWorkbook.Name
pfad = "C:\Users\ich\Desktop\Programmieung\hallo\Neuer Ordner" 'noch anpassen
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
quelle = "Datei2.xls" 'x
Workbooks.Open Filename:=pfad & quelle
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
ReDim loschen(zeilen)
For k = 1 To zeilen
loschen(k) = 0
Next k
For k = 1 To zeilen
loschen(k) = 0
Next k
For k = 1 To 3
For l = 1 To parameter(2 * k - 1, 0)
suche = parameter(2 * k - 1, l)
If suche <> "" Then
ersetz = parameter(2 * k, l)
If k = 1 Or k = 2 Then
spalte = 3
Else
spalte = 4
End If
With Workbooks(quelle).Worksheets(1).Columns(spalte)
Set ergebnis = .Find(suche, LookIn:=xlValues)
If Not ergebnis Is Nothing Then
letzter = Application.WorksheetFunction.CountIf(Workbooks(quelle).Worksheets(1).Columns(spalte), "*" & suche & "*")
For j = 1 To letzter
If ersetz = "" And k = 1 Then
loschen(0) = loschen(0) + 1
loschen(ergebnis.Row) = 1
Else
Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, spalte) = Replace(Workbooks(quelle).Worksheets(1).Cells(ergebnis.Row, spalte), suche, ersetz)
End If
Set ergebnis = .FindNext(ergebnis)
Next j
End If
End With
Set ergebnis = Nothing
End If 'Verglich ob leer
Next l
Next k
'jetzt löschen
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
Workbooks(quelle).Close savechanges:=True
Application.ScreenUpdating = True
End Sub
|