Matrix mit Daten un täglichen Mengen als neue Matrix mit Losgrößen

Sub KonsolidiereUndPlaneProduktion()
    Dim ws As Worksheet, wsNeu As Worksheet
    Dim letzteZeile As Long, letzteSpalte As Long
    Dim i As Long, j As Long
    Dim täglicherBedarf As Double, gesamtBedarf As Double
    Dim Losgröße As Double, tage As Long
    Dim MaxTagesmenge As Double
    Dim Prio As Boolean
    Dim neueZeile As Long
    Dim versandPlan As Collection
    Dim arrData As Variant, arrHeader As Variant, arrOutput As Variant

    Set ws = ThisWorkbook.Sheets("Tabelle1")
    MaxTagesmenge = 2200

    On Error Resume Next
    Set wsNeu = ThisWorkbook.Sheets("Neue Matrix")
    On Error GoTo 0
    If wsNeu Is Nothing Then
        Set wsNeu = ThisWorkbook.Sheets.Add(After:=ws)
        wsNeu.Name = "Neue Matrix"
    End If

    Application.ScreenUpdating = False

    letzteZeile = ws.Cells(Rows.Count, 1).End(xlUp).Row
    letzteSpalte = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    arrData = ws.Range(ws.Cells(1, 1), ws.Cells(letzteZeile, letzteSpalte)).Value

    arrHeader = ws.Range(ws.Cells(1, 1), ws.Cells(1, letzteSpalte)).Value

    Set versandPlan = New Collection

    For i = 2 To letzteZeile
        täglicherBedarf = 0
        For j = 8 To letzteSpalte
            täglicherBedarf = täglicherBedarf + arrData(i, j)
        Next j

        Prio = arrData(i, 7)

        If Not Prio Then
            Losgröße = Application.WorksheetFunction.Min(MaxTagesmenge, täglicherBedarf)
            tage = WorksheetFunction.Ceiling(täglicherBedarf / Losgröße, 1)
        End If

        For j = 8 To letzteSpalte
            If arrData(i, j) > 0 Then
                Dim MengenText As String
                If Prio Then
                    MengenText = Application.WorksheetFunction.Min(arrData(i, j), MaxTagesmenge) & "/" & 1
                Else
                    MengenText = Application.WorksheetFunction.Min(arrData(i, j), Losgröße) & "/" & tage
                End If
                versandPlan.Add Array(i, j, MengenText)
                arrData(i, j) = arrData(i, j) - Val(Split(MengenText, "/")(0))
            End If
        Next j
    Next i

    ReDim arrOutput(1 To letzteZeile, 1 To letzteSpalte)

    For i = 1 To 7
        For j = 1 To letzteSpalte
            arrOutput(i, j) = arrData(i, j)
        Next j
    Next i

    For i = 8 To letzteZeile
        For j = 1 To letzteSpalte
            arrOutput(i, j) = arrData(i, j)
        Next j
    Next i

    For i = 1 To versandPlan.Count
        Dim rowIndex As Long
        rowIndex = versandPlan(i)(0)
        arrOutput(rowIndex, versandPlan(i)(1)) = versandPlan(i)(2)
    Next i

    wsNeu.Range("A1").Resize(UBound(arrOutput, 1), UBound(arrOutput, 2)).Value = arrOutput

    Application.ScreenUpdating = True

    MsgBox "Versandplan erfolgreich erstellt!", vbInformation
End Sub