In der Spalte Copy gebe ich also an, wie of die jeweilige Zeile in der neuen Tabelle kopiert werden soll.
Gibt es dafür ein Makro?
https://www.herber.de/bbs/user/96957.xlsx
Vielen Dank schon mal für Eure Hilfe!
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim x As Long
Application.ScreenUpdating = False
If Target.Column = 4 And Not IsEmpty(Target) Then
If Cells(Target.Row, 1).Value = "" Or Cells(Target.Row, 2).Value = "" Or Cells(Target.Row, 3). _
Value = "" Then
Target = ""
Cells(Target.Row, 1).Select
MsgBox "Erst alle Datenfelder füllen."
Exit Sub
Else
If Not IsNumeric(Target) Then
MsgBox "Nur Eingabe von Zahlen zulässig."
Target = ""
Target.Select
Exit Sub
Else
i = Cells(Rows.Count, 7).End(xlUp).Row + 1
x = Target.Value
Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Copy
Cells(i, 7).Resize(x).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End If
End If
End If
Application.ScreenUpdating = True
End Sub
Im Code wird die letzte belegte Zelle in Spalte G ermittelt und danach die Daten reinkopiert.
Option Explicit
Sub CopyXMal()
Const ColCopy As Long = 4
Const ColFrom As Long = 1
Const ColTill As Long = 3
Const ColTo As Long = 7
Const RowStart As Long = 2
Dim RowEnd As Long
Dim RowEndTo As Long
Dim r As Range
With ActiveSheet
RowEnd = .Cells(.Rows.Count, ColCopy).End(xlUp).Row
For Each r In .Range(.Cells(RowStart, ColCopy), .Cells(RowEnd, ColCopy))
RowEndTo = .Cells(.Rows.Count, ColTo).End(xlUp).Row + 1
.Range(.Cells(r.Row, ColFrom), .Cells(r.Row, ColTill)).Copy
If r.Value > 0 Then
.Cells(RowEndTo, ColTo).Resize(r.Value, 1).PasteSpecial
Application.CutCopyMode = False
End If
Next r
End With
End Sub
Das funktioniert aber nur, wenn du die Bereiche nicht als seperate Tabellen deklarierst, wie du es in deiner Musterdatei getan hast.
.Cells(RowEndTo, ColTo).Resize(r.Value, 1).PasteSpecial (xlPasteValues)
Gruß Werner