一维下料优化

Sub CutPlan()
    Me.Select
    Dim ar, a&(), b(), c&(), d(), dic, tr, i&, i1&, j&, j1&, k&, l&, l1&, m&, m1&, n&, r&, r1&, r2&, s@, t&, u@, u1@, v@, v1@, w$, x#, tms#
    n = [b1].End(4).Row - 1 'B列数据个数m
    m = Application.Sum([c2].Resize(n)) 'C列个数总和n
    u = Application.Max([b2].Resize(n)) 'B列最大值u
    u1 = Application.Min([b2].Resize(n)) 'B列最小值u1
    v = Val([d2]): v1 = Val([d3])
    Do Until v >= u
        v = Val(InputBox("输入每组最大限额", "凑数", u)): [d2] = v
        '如当前数据中最大值u 超过了基础量v将无法正确计算，所以需要重新设置基础量v
    Loop
    v = v + v1
    tms = Timer '开始计时
    ar = WorksheetFunction.Transpose([a2].Resize(n, 4)) '读取3列原始数据到数组ar
    ReDim a&(1 To m) '定义数组a
    ReDim b(-1 To m, -3 To n)
    b(-1, -3) = "项数": b(-1, -2) = "根数": b(-1, -1) = "需求计划： " & n & " 规格 / " & m & " 根": b(-1, 0) = "剩余数"
    For j = 1 To n
        b(-1, j) = ar(2, j)
        u = ar(2, j): l = ar(3, j): ar(4, j) = u + v1 '取得规格长度数据u、根数l
        s = s + u * l '统计长度Sum总和s
        For l = 1 To l '遍历根数n
            k = k + 1: a(k) = j '单根数据序号
        Next
    Next
    i1 = s \ v: If i1 * v < s Then i1 = i1 + 1
    b(0, -1) = "方案明细：规格*根数(理想数=" & i1 & ")"
    Set dic = CreateObject("Scripting.Dictionary")
    l1 = [d11]: If l1 = 0 Then l1 = m \ n 'l1 = Log(n)
    For i = 1 To m
        dic.RemoveAll
        For l = 0 To l1
            ReDim c&(1 To m): m1 = m
            Do
                ReDim d(n)
                u = v
                For k = 1 To m
                    If c(k) = 0 Then
                        j = a(k)
                        If u >= ar(4, j) Then
                            m1 = m1 - 1: c(k) = 1: d(j) = d(j) + 1
                            u = u - ar(4, j)
                            If u < u1 Then Exit For
                        End If
                    End If
                Next
                w = Join(d, ",")
                If Not dic.exists(w) Then
                    r1 = m
                    For j = 1 To n
                        If d(j) Then r = ar(3, j) \ d(j): If r < r1 Then r1 = r
                    Next
                    dic(w) = Val(CCur(-(Int(-u / u1)) + 1 - r / m))
                End If
            Loop While m1
            If l < l1 Then
                Randomize '随机种子初始化 确保随机性
                For k = 1 To m
                    r = Int(Rnd() * (m - k + 1)) + k
                    t = a(r): a(r) = a(k): a(k) = t
                Next
            End If
        Next
        tr = dic.items
        x = WorksheetFunction.Min(dic.items)
        l = WorksheetFunction.Match(x, tr, 0) - 1
        w = dic.keys()(l)
        tr = Split(w, ",")
        k = 0: u = v: r1 = m: w = ""
        For j = 1 To n
            If tr(j) <> "" Then
                k = k + 1: t = tr(j): u = u - ar(4, j) * t
                r = ar(3, j) \ t: If r < r1 Then r1 = r
                b(i, j) = t: w = w & "+" & ar(2, j) & "*" & t
            End If
        Next
        For j = 1 To n
            If tr(j) <> "" Then
                t = tr(j): ar(3, j) = ar(3, j) - r1 * t: b(0, j) = b(0, j) + r1 * t: m = m - r1 * t
            End If
        Next
        b(i, 0) = Val(u): b(i, -1) = mid(w, 2): b(i, -2) = r1: b(i, -3) = k:
        b(0, -2) = b(0, -2) + r1
        b(0, 0) = b(0, 0) + Application.Evaluate(w) * r1
        Application.StatusBar = Format(Timer - tms, "0.00s") & " 已完成" & Format(b(0, 0) / s, "(0.0%)") & "、估计尚需 " & Format((s / b(0, 0) - 1) * (Timer - tms), "0.00s")
        If b(0, 0) = s Then Exit For  '【已完成总计】等于Sum总和s时 结束
        '        [g1].Resize(2 + i, 4 + n) = b
        ReDim a&(1 To m): k = 0
        For j = 1 To n
            For l = 1 To ar(3, j)
                k = k + 1: a(k) = j '单根数据序号
            Next
        Next
    Next
    b(0, -3) = i: t = b(0, -2)
    [g1].CurrentRegion.Clear '清空输出数据区域
    Cells.Font.Size = 9
    [g1].Resize(2 + i, 4 + n) = b '输出数组br结果
    [g3].Resize(i, 4 + n).Sort [j3], 1, [h3], , 2, [g3], 1, 2 '按第1列原数据序号进行恢复性排序
    [g1].Resize(, 4 + n).EntireColumn.AutoFit      '所有列进行列幅自动修正
    [g1].Resize(2 + i, 4 + n).Borders.LineStyle = 1 '输出数据区域画格子线
    MsgBox "OK"
End Sub

Sub splitbr()
    b = Me.Range("g1").CurrentRegion
    For x = 3 To UBound(b)
        s = Split(b(x, 3), "+")
        If UBound(s) > 3 Then
        End If
    Next
End Sub

G:\0.programming_order\0.稍早前\202005\0525\下料优化