Hallo zusammen,
ich würde gerne aus einem Tabellenblatt bestimmte Zellen in ein zweites Tabellenblatt kopieren.
Es soll Spalte B, C und D kopiert werden, wenn in Spalte E ein "x" steht. Der Bereich in dem sich die Werte befinden, ist A34:E120.
In Tabelle 2 sollen die Werte ab Zeile 16 in die Spalten B, C und D eingefügt werden. In Spalte A sollen Positionen gesetzt werden, je nach Anzahl der Zellen in Tabelle 1, die ein x enthalten.
Aus einem anderen Makro habe ich folgenden Code, jedoch bekomme ich es nicht hin diesen so umzuschreiben, dass es in meinem Fall funktioniert:
Dim TB1, TB1Z1 As Integer, LR1 As Integer, SP As Integer, RNG As Range
Dim TB2, TB2Z1 As Integer, LR2 As Integer
Set TB1 = Sheets("Tabelle 1")
Set TB2 = Sheets("Tabelle 2")
Set RNG = TB1.Columns("B") 'Bereich, der übertragen werden soll
TB1Z1 = 35 'erste Zeile mit Daten
TB2Z1 = 17 'erste Zielzeile
SP = 3 'Spalte mit Mengenangaben "C"
LR1 = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
With TB1.Cells(TB1Z1, SP).Resize(LR1 - TB1Z1 + 1, 1)
'Prüfen ob Mengen eingetragen wurden
If WorksheetFunction.Sum(.Cells) > 0 Then
'Reset Zieltabelle
LR2 = TB2.Cells(TB2.Rows.Count, "C").End(xlUp).Row 'Letzte Zeile
TB2.Cells(TB2Z1, 1).EntireRow.ClearContents 'erste zeile leeren
TB2.Cells(TB2Z1 + 1, 1).Resize(LR2, 1).EntireRow.Delete xlUp 'Rest löschen
'Nur Zeilen mit Menge übertragen
Intersect(RNG, .SpecialCells(xlCellTypeConstants, 3).EntireRow).Copy TB2.Cells(TB2Z1, 2)
'Positionen setzen
LR2 = TB2.Cells(TB2.Rows.Count, "C").End(xlUp).Row 'Letzte Zeile
With TB2.Cells(TB2Z1, 1).Resize(LR2 - TB2Z1 + 1, 1)
.FormulaR1C1 = "=ROW(R[-2]C)"
.Value = .Value
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlEdgeBottom).Weight = xlMedium
End With
'Format aus Zeile 3 übertragen
TB2.Cells(TB2Z1, 1).EntireRow.Copy
TB2.Cells(TB2Z1, 1).Resize(LR2 - TB2Z1 + 1, 1).EntireRow.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub
Falls ich etwas vergessen habe, lasst mich es einfach wissen.
Vielen Dank für eure Hilfe.
Beste Grüße
Chris