Sepp Ehrensberger hat mir gestern nachfolgenden Code geschrieben, der seine Aufgabe hervorragend erledigt. Ich habe nun aber eine ähnliche Aufgabenstellung, wozu der Code angepasst werden muss.
Dazu brauche ich aber erneut eure Hilfe.
Die Quelle ist wieder die Tabelle "Daten" (identisch mit vorheriger Aufgabe).
Unterschiede: Zieltabelle ist nun die Tabelle "Daten2", die ebenfalls ab Zeile 5 "gefüllt" werden sollte. Der Unterschied zur früheren Aufgabenstellung stelle ich wie folgt dar:
1. es sollen die Datensätze übertragen werden, bei denen die "x" in einer der
Spalten K bis AD stehen und zwar jeweils der Spalte, bei der der Wert in
der Zeile 4 dem Wert der Zelle L3 entspricht, also ist der Wert in M4
identisch mit dem Wert von L3 sollen die Datensätze ausgewählt werden, die
im Bereich M5:M421 mit einem "x" versehen sind.
2. Die Datenfelder der Spalten B,C und D und G der Quelltabelle "Daten" sollen
in die gleichen Spalten der Zieltabelle eingetragen werden, die Daten aus
der Spalte E (Quelltabelle) sollten in die Spalte F (Zieltabelle)
geschrieben werden.
3. Vor dem Kopieren sollte in der Zieltabelle jeweils nur der Bereich B5:D421
und G5:F421 gelöscht werden.
Vielen Dank für die Hilfe.
Gruß
Fritz
Hier der bisherige Code:
Sub Daten_Uebertragen() Dim quelle As Worksheet Dim ziel As Worksheet Dim rng As Range Dim lRow As Long Dim lastRow As Long Set quelle = Sheets("Daten") Set ziel = Sheets("Daten1") With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .Calculation = xlCalculationManual End With lastRow = 5 ziel.Range(" B5:G421").ClearContents With quelle For lRow = 5 To 421 If LCase(.Cells(lRow, 10)) = "x" Then Set rng = Union(.Cells(lRow, 2), .Cells(lRow, 3), .Cells(lRow, 5), _ .Cells(lRow, 7), .Cells(lRow, 8), .Cells(lRow, 9)) rng.Copy ziel.Cells(lastRow, 2).PasteSpecial xlPasteValues lastRow = lastRow + 1 End If Next End With With Application .CutCopyMode = False .ScreenUpdating = True .EnableEvents = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With End Sub