如何按单元格指定容量对长度数组进行分组嵌套？

需求说明 #

现有一个物品长度数组，需将数组元素放入指定容量的盒子中，计算所需盒子数量并完成分组：

• 示例输入：长度数组(2,2,4,5,5,10,3,3,3,1)，盒子容量为10
• 预期输出：

你需要4个盒子，分组方式如下：
1(10)
2(5,5)
3(3,3,3,1)
4(2,2,4)

现有待完善代码 #

Public Sub Nestarray()
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Dim lenght() As Variant
Dim lenghtgroup() As Variant

Set ws = ActiveSheet

'First array
lr = Cells(Rows.Count, "D").End(xlUp).Row
lenght = ws.Range("D2:D" & lr).Value

'Second array I give space between stuff
ReDim lenghtgroup(LBound(lenght, 1) To UBound(lenght, 1), 1 To 1)
For i = LBound(lenght, 1) To UBound(lenght, 1)
    If Int(lenght(i, 1)) = ws.Range("H3").Value Then
        lenghtgroup(i, 1) = Int(lenght(i, 1))
    Else
        lenghtgroup(i, 1) = Int(lenght(i, 1) + ws.Range("H4").Value)
    End If

Next i
End Sub

完善后的VBA代码 #

Public Sub NestArray()
    Dim ws As Worksheet
    Dim lr As Long, i As Long, boxCount As Long, currentSum As Long
    Dim lengths() As Variant, tempArr As Collection
    Dim boxGroups As Collection
    Dim outputStr As String
    
    ' 绑定当前工作表
    Set ws = ActiveSheet
    Set boxGroups = New Collection
    
    ' 读取D列的物品长度数据
    lr = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    lengths = ws.Range("D2:D" & lr).Value
    
    ' 配置参数：盒子容量（可改为ws.Range("H3").Value）、物品间预留空间
    Const BOX_CAPACITY As Long = 10
    Dim SPACE_BETWEEN As Double: SPACE_BETWEEN = ws.Range("H4").Value
    
    ' 预处理：提取有效长度并转为集合
    Dim tempList As Collection
    Set tempList = New Collection
    For i = LBound(lengths, 1) To UBound(lengths, 1)
        If Not IsEmpty(lengths(i, 1)) And lengths(i, 1) > 0 Then
            tempList.Add lengths(i, 1)
        End If
    Next i
    
    ' 转为数组并降序排序（贪心算法优先装长物品，提升装箱效率）
    Dim sortedLengths() As Double
    ReDim sortedLengths(1 To tempList.Count)
    For i = 1 To tempList.Count
        sortedLengths(i) = tempList(i)
    Next i
    Call BubbleSortDesc(sortedLengths)
    
    ' 执行装箱逻辑
    boxCount = 0
    Do While UBound(sortedLengths) >= 1
        boxCount = boxCount + 1
        currentSum = 0
        Set tempArr = New Collection
        
        ' 尝试将剩余物品放入当前盒子
        Dim j As Long, k As Long
        k = 1
        Do While k <= UBound(sortedLengths)
            Dim itemWithSpace As Double
            itemWithSpace = sortedLengths(k) + IIf(tempArr.Count > 0, SPACE_BETWEEN, 0)
            
            If currentSum + itemWithSpace <= BOX_CAPACITY Then
                tempArr.Add sortedLengths(k)
                currentSum = currentSum + itemWithSpace
                
                ' 移除已装入的物品
                For j = k To UBound(sortedLengths) - 1
                    sortedLengths(j) = sortedLengths(j + 1)
                Next j
                ReDim Preserve sortedLengths(1 To UBound(sortedLengths) - 1)
                k = k - 1 ' 移除元素后索引回退
            End If
            k = k + 1
        Loop
        
        ' 保存当前盒子的分组
        boxGroups.Add tempArr
    Loop
    
    ' 生成指定格式的输出字符串
    outputStr = "你需要" & boxCount & "个盒子，分组方式如下：" & vbCrLf
    For i = 1 To boxGroups.Count
        outputStr = outputStr & i & "("
        For j = 1 To boxGroups(i).Count
            outputStr = outputStr & boxGroups(i)(j)
            If j < boxGroups(i).Count Then outputStr = outputStr & ","
        Next j
        outputStr = outputStr & ")" & vbCrLf
    Next i
    
    ' 输出结果：弹窗展示，也可改为写入单元格（如ws.Range("J2").Value = outputStr）
    MsgBox outputStr
End Sub

' 辅助函数：降序冒泡排序
Private Sub BubbleSortDesc(arr() As Double)
    Dim i As Long, j As Long, temp As Double
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) < arr(j) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
End Sub

代码说明 #

• 数据预处理：读取D列有效长度数据，过滤空值后降序排序，用贪心策略提升装箱效率
• 装箱逻辑：逐个尝试将物品放入当前盒子，加入物品时自动计算预留空间，直到盒子容量不足
• 结果输出：生成符合要求的格式字符串，通过弹窗展示，也可修改为写入指定单元格
• 参数配置：盒子容量可直接改为从H3单元格读取，适配不同业务需求

内容的提问来源于stack exchange，提问作者mesyen