Option Explicit

'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=111005&TITLE_SEO=111005-summirovat-dliny-2000-summa-ne-dolzhna-prevyshat-porog&MID=921474#message921474
Sub jjj()
    Const dLenCondition# = 2000
    Dim rngSrcData As Range: Set rngSrcData = [A2:B28]
    Dim arrSrcData(): arrSrcData = rngSrcData.Value
    Dim dMaxLen#: dMaxLen = WorksheetFunction.Max(rngSrcData.Columns(2))
    
    Dim dSum#: dSum = 0
    Dim lCnt&: lCnt = 0
    Dim i&, arrOut()
    Dim rngRow As Range
    For i = 1 To UBound(arrSrcData, 1)
        If arrSrcData(i, 2) <= dLenCondition Then
            Do While arrSrcData(i, 1) > 0
                If dSum + arrSrcData(i, 2) >= dMaxLen Then
                    lCnt = lCnt + 1
                    ReDim Preserve arrOut(1 To lCnt)
                    arrOut(lCnt) = dSum
                    dSum = 0
                End If
                dSum = dSum + arrSrcData(i, 2)
                arrSrcData(i, 1) = arrSrcData(i, 1) - 1
            Loop
        End If
    Next i
    
    If dSum > 0 Then
        lCnt = lCnt + 1
        ReDim Preserve arrOut(1 To lCnt)
        arrOut(lCnt) = dSum
    End If
    
    With Workbooks.Add
        With .Worksheets(1)
            With .Cells(1, 1).Resize(lCnt)
                For i = 1 To lCnt
                    .Cells(i).Value = arrOut(i)
                Next i
            End With
        End With
    End With
End Sub