Zeilen so oft kopieren wie Zellwert

Guten Tag, liebe Forum-Gemeinde,
ich hoffe, ihr könnt mir bei meinem Problem helfen. Ich habe ein Worksheet mit Bestellungen und soll nun Zeilen, bei denen sich der Bestellstatus ändert (händische Eingabe), in ein anderes Worksheet (Geräteliste) übertragen. Die Suche nach dem Bestellstatus und eine Abänderung des Status in der Folge, sowie die Kopie in das andere Worksheet habe ich schon geschrieben, jedoch kann eine Bestellung(/Zeile) mehrere Geräte enthalten , weswegen die Zeile so oft kopiert werden soll, wie die Bestellung Geräte enthält.
Leider habe ich mich erst letzte Woche in das Thema VBA eingelesen und noch zu wenige Kenntnisse, um diese Aufgabe umzusetzen. Die Suche brachte mir leider auch keinen Erfolg bzw. ich kann die gelösten Probleme nicht auf meines übertragen.
Ich hoffe, ihr könnt mir helfen!
Viele Grüße

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Const cZielTabelle = "Geräteliste" Const cStatusMove = "bestellt" Const cStatusCopy = "übertragen" Dim wsZiel As Worksheet Dim lZielRow As Long, rC As Range ' Check auf Veränderung ab Zeile 4 in Spalte 3 If Target.Row > 4 And Target.Column = 3 Then Application.EnableEvents = False ' Alle Zeilen die bestellt sind nach Ziel kopieren und auf cStatusCopy ändern Set wsZiel = ThisWorkbook.Worksheets(Replace(Me.Name, "Bestellungen", cZielTabelle)) For Each rC In Intersect(Target, Range(Cells(5, 3), Cells(Rows.Count, 3))) If rC = cStatusMove Then lZielRow = wsZiel.Cells(wsZiel.Rows.Count, 1).End(xlUp).Row + 1 rC = cStatusCopy Rows(rC.Row).Copy wsZiel.Cells(lZielRow, 1) wsZiel.Rows(lZielRow).Value = wsZiel.Rows(lZielRow).Value End If Application.EnableEvents = True Next rC End If End Sub

Hallo alex,
Das mit den Anzahl Produkten hab ich übersehen. Auch wenn mir der Sinn dieser Anwendung verborgen bleibt, so werden n-mal (0...n) die Zeilen kopiert:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const cZielTabelle = "Geräteliste"
Const cStatusMove = "bestellt"
Const cStatusCopy = "übertragen"
Dim wsZiel As Worksheet
Dim lZielRow As Long, lCnt As Long, rC As Range
' Check auf Veränderung ab Zeile 4 in Spalte 3
If Target.Row > 4 And Target.Column = 3 Then
Application.EnableEvents = False
' Alle Zeilen die bestellt sind nach Ziel kopieren und auf cStatusCopy ändern
Set wsZiel = ThisWorkbook.Worksheets(Replace(Me.Name, "Bestellungen", cZielTabelle))
For Each rC In Intersect(Target, Range(Cells(5, 3), Cells(Rows.Count, 3)))
If rC = cStatusMove Then
rC = cStatusCopy
' Es wird 0 - n mal kopiert, je nach der Anzahl in Spalte N
For lCnt = 1 To CLng(rC.Offset(0, 11))
lZielRow = wsZiel.Cells(wsZiel.Rows.Count, 1).End(xlUp).Row + 1
Rows(rC.Row).Copy wsZiel.Cells(lZielRow, 1)
wsZiel.Rows(lZielRow).Value = wsZiel.Rows(lZielRow).Value
Next lCnt
End If
Application.EnableEvents = True
Next rC
End If
End Sub

Gruess Hansueli

Beliebteste Forumthreads (12 Monate)

Zeilen so oft kopieren wie Zellwert

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread