AW: @Jan Freytag - Code anpassen
21.02.2020 19:37:18
Matthias
Moin!
Habe mal getestet. So sollte es passen. Hatte vergessen zu prüfen, ob die Summe negativ wird und sie einfac so abgezogen.
Sub Aufteilen2()
Dim lngLetzte As Long
Dim lngEinfüg As Long
Dim i As Long
Dim dblMaxKapa As Double
Dim fVarProd As Variant
Dim lngStück As Long
Dim lngFormen As Double
Dim lngCalcStatus As Long
Dim dblAufgeteilt As Double
On Error GoTo ErrExit
lngCalcStatus = Application.Calculation
Application.Calculation = xlCalculationManual
lngEinfüg = Application.Max(8, Worksheets("F7 Soll ausgelastet").Cells(Worksheets("F7 Soll _
ausgelastet").Rows.Count, _
1).End(xlUp).Row + 1)
With Worksheets("F7 Artikelebene")
dblMaxKapa = .Cells(2, "Y").Value
lngLetzte = .Cells(.Rows.Count, "W").End(xlUp).Row
For i = 4 To lngLetzte 'start in 5 nicht in 4
If .Cells(i, "W").Value "" Then
fVarProd = .Cells(i, "W").Resize(, 2).Value
dblStück = CDbl(.Cells(i, "Y").Value)
lngFormen = .Cells(i, "AA").Value
Do
With Worksheets("F7 Soll ausgelastet")
.Cells(lngEinfüg, 1).Resize(1, 2).Value = fVarProd
.Cells(lngEinfüg, 3).Value = Application.Min(dblMaxKapa, dblStück)
dblStück = dblStück - dblMaxKapa
lngFormen = lngFormen - 1
If lngFormen 0 Then .Cells(lngEinfüg, 3).Value = CDbl(. _
Cells(lngEinfüg, 3).Value) + dblStück
lngEinfüg = lngEinfüg + 1
End With
Loop While dblStück > 0 And lngFormen > 0
End If
Next i
End With
ErrExit:
Application.Calculation = lngCalcStatus
End Sub
Teste bitte nochmal. Wenn es noch nicht das richtige war, dann bitte nochmal melden.
VG