AW: Datensatz aus Tabelle in andere kopieren
15.03.2022 09:18:49
Steve
Hallo Michael,
so funktioniert es unabhängig von der aktuellen Cursorposition, respektive der aktuellen Zelle:
Sub Versch_Stahl1_Click()
Dim wZ As Worksheet
Dim LR
If ActiveSheet.Name Ausw_kop_Stahl1.Text Then
If Not Intersect(Selection, Range("B17:S2500")) Is Nothing Then
Worksheets(Ausw_kop_Stahl1.Text).Unprotect "suse"
With Worksheets("Stahl 1").ListObjects("ProdplanStahl1")
For Each LR In .ListRows
Set LR = LR.Range.EntireRow
If Not Intersect(Selection, LR) Is Nothing Then
Set wZ = ActiveWorkbook.Sheets(Ausw_kop_Stahl1.Text)
Set z = wZ.Range("D99999").End(xlUp)
If z = "" Then Set z = z.End(xlUp).Offset(1) Else Set z = z.Offset(1)
Set z = z.EntireRow
z.Range("D1:H1") = LR.Range("D1:H1").Value
z.Range("K1") = LR.Range("K1").Value
z.Range("N1:S1") = LR.Range("N1:S1").Value
End If
Next
End With
End If
End If
Selection.EntireRow.Delete
Worksheets(Ausw_kop_Stahl1.Text).Protect Password:="suse", AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, userinterfaceonly:=True
End Sub
So wie ich das jetzt verstehe läuft das dann folgendermaßen ab:(?)
With Worksheets("Stahl 1").ListObjects("ProdplanStahl1")
For Each LR In .ListRows
Set LR = LR.Range.EntireRow
Inhalte der Tabelle werden aufgelistet; in LR wird die ganze Zeile hinterlegt
If Not Intersect(Selection, LR) Is Nothing Then
aus der Liste wird nun der Datensatz, auf dem die aktuelle Zelle steht ausgewählt
z.Range("D1:H1") = LR.Range("D1:H1").Value
z.Range("K1") = LR.Range("K1").Value
z.Range("N1:S1") = LR.Range("N1:S1").Value
Der gewählte Datensatz in der Quelle steht in der Auflistung nun in Zeile 1, die frei Zeile im Ziel wurde vorher auch irgendwie ermittelt und hier wird auch in Zeile 1 eingefügt. Mit der Änderung von "Selection" auf "LR" ist nun die gesamte Zeile der Quelle ausgewählt durch LR = LR.Range.EntireRow. und damit spielt die Cursorposition keine Rolle mehr beim kopieren.
So verstehe ich das jetzt mit meinem Halbwissen.
In jedem Fall macht auch dieses Makro nun das, was es soll. ich werde es weiter testen.
Vielen Dank nochmal für deine Hilfe Michael!
Viele Grüße
Steve