Legen Sie die gesamte Zeile bestimmten Zellwert mit VBA mit

Question

Ich habe das Problem in diesem Format

from hrs to hrs quantum rate 
12:00:00 6:00:00 100  1.8 
12:00:00 5:00:00 125  1.6 

ich diese Daten will in bestimmtem Format wie

from hrs to hrs  quantum rate 
12:00:00 6:00:00  -50  1800.00 
12:00:00 6:00:00  -50  1800.00 
12:00:00 5:00:00  -50  1600.00 
12:00:00 5:00:00  -50  1600.00 
12:00:00 5:00:00  -25  1600.00 

und ich den Code unten bin mit:

Option Explicit 

Sub main() 
    Dim data As Variant 
    Dim iData As Long, datum As Long, iRow As Long 
With Range("A1", Cells(Rows.Count, 1).End(xlUp)) 
    data = .Resize(, 4).Value 
    iData = LBound(data) 
    Do 
     datum = data(iData, UBound(data, 2) - 1) 
     Do While datum > 0 
      iRow = iRow + 1 
      .Cells(iRow).Resize(, 4) = Application.Index(data, iData, 0) 
      .Cells(iRow, UBound(data, 2) - 1).Value = WorksheetFunction.Min(50, datum) 
      datum = datum - 50 
     Loop 
     iData = iData + 1 
    Loop While iData <= UBound(data) 
    .Resize(1).Copy 
    .Resize(iRow).PasteSpecial xlPasteFormats 
    Application.CutCopyMode = False 
End With 
End Sub 

Answer 1

hier ist sie:

Option Explicit 

Sub main() 
    Dim data As Variant 
    Dim iData As Long, datum As Long, iRow As Long 
    With Range("A1", Cells(Rows.Count, 1).End(xlUp)) 
     data = .Resize(, 4).Value 
     iData = LBound(data) 
     Do 
      datum = data(iData, UBound(data, 2) - 1) 
      Do While datum > 0 
       iRow = iRow + 1 
       .Cells(iRow).Resize(, 4) = Application.Index(data, iData, 0) 
       .Cells(iRow).Offset(, 3).Value = .Cells(iRow).Offset(, 3).Value * 1000 
       .Cells(iRow, UBound(data, 2) - 1).Value = -WorksheetFunction.Min(50, datum) 
       datum = datum - 50 
      Loop 
      iData = iData + 1 
     Loop While iData <= UBound(data) 
     .Resize(1, 4).Copy 
     .Resize(iRow, 4).PasteSpecial xlPasteFormats 
     Application.CutCopyMode = False 
    End With 
End Sub