Zeileneintrag aufteilen
23.06.2022 08:35:02
Tim
meine Ausgangssituation ist, dass in meiner Ursprungsdatei es Zeilen gibt, deren Wert in einer bestimmten Zelle >1 ist.
Im zweiten Tabellenblatt möchte ich dann die Zeilen übertragen und wenn der Wert >1, die Ausgangszeile so oft eingefügt wird, wie es der Wert aus der bestimmten Zelle vorgibt.
Aktuell bekomme ich die Anzahl der Zeilen eingefügt, jedoch überträgt er den Inhalt nicht, wie kann man das lösen!?
Sub Test()
Dim WbQ As Workbook, WbZ As Workbook
Dim WsQ As Worksheet, WsZ As Worksheet
Dim i As Long, letzte As Long, ImportListe As Long
Set WbQ = ThisWorkbook
Set WsQ = WbQ.Worksheets(1)
Set WsZ = WbQ.Worksheets(2)
letzte = WsQ.Cells(WsQ.Rows.Count, 1).End(xlUp).Row
ImportListe = WsZ.Cells(WsZ.Rows.Count, 1).End(xlUp).Row
For i = 2 To letzte
If WsQ.Cells(i, 4) > 1 Then
WsZ.Cells(ImportListe + 1, 1) = WsQ.Cells(i, 1).Value
WsZ.Cells(ImportListe + 1, 2) = WsQ.Cells(i, 2).Value
WsZ.Cells(ImportListe + 1, 3) = WsQ.Cells(i, 3).Value
WsZ.Cells(ImportListe + 1, 4) = WsQ.Cells(i, 4).Value
WsZ.Cells(ImportListe + 1, 5) = WsQ.Cells(i, 5).Value
WsZ.Cells(ImportListe + 1, 6) = WsQ.Cells(i, 6).Value
WsZ.Cells(ImportListe + 1, 7) = WsQ.Cells(i, 7).Value
ImportListe = ImportListe + WsQ.Cells(i, 4).Value
Else
WsZ.Cells(ImportListe + 1, 1) = WsQ.Cells(i, 1).Value
WsZ.Cells(ImportListe + 1, 2) = WsQ.Cells(i, 2).Value
WsZ.Cells(ImportListe + 1, 3) = WsQ.Cells(i, 3).Value
WsZ.Cells(ImportListe + 1, 4) = WsQ.Cells(i, 4).Value
WsZ.Cells(ImportListe + 1, 5) = WsQ.Cells(i, 5).Value
WsZ.Cells(ImportListe + 1, 6) = WsQ.Cells(i, 6).Value
WsZ.Cells(ImportListe + 1, 7) = WsQ.Cells(i, 7).Value
ImportListe = ImportListe + 1
End If
Next
Set WbQ = Nothing: Set WbZ = Nothing: Set WsQ = Nothing
Set WsZ = Nothing
End Sub