规划求解的问题

EarlGrey

请教一个规划的问题：
附件表分成三个部分，左侧是成品序号以及待输入的数量，中间计算了各个成品耗用的料件数量，右侧是将中间得来的料件耗用数量按料件汇总。其中N列为各个料件的单价，单元格N120为各个料件数量乘上各自单价的总和。我目前在C列手工随意输入，费时费力还找不到最优解。
目标：C列输入各个成品的数量，使得单元格N120的总金额最大。
约束：C列输入的成品数量小于等于B列各自对应的数量，M生成的料件耗用数量小于等于L列各自对应的数量。

EarlGrey

增加一个约束条件：C列输入的成品数量应大于等于0

yynrzwh

供参考，结果和楼主不一样
010820250109.zip (150.57 KB, 下载次数: 6)

2025-1-9 16:47 上传

点击文件名下载附件

Sub test4() 'by yynrzwh 20250109

With Sheet1
    lr = .Cells(Rows.Count, 1).End(3).Row
    .[c2].Resize(lr - 1).ClearContents
    ar = .[a1].CurrentRegion
    br = .[e1].CurrentRegion
    cr = .[k1].CurrentRegion
End With

Set d = VBA.CreateObject("scripting.dictionary")
Set ljyl = VBA.CreateObject("scripting.dictionary")

For i = 2 To UBound(cr)
    ljyl(cr(i, 1)) = Array(cr(i, 2), cr(i, 3), cr(i, 4))
Next

For i = 2 To UBound(br)
    s = br(i, 1)
    If Not d.exists(s) Then
        Set d(s) = VBA.CreateObject("scripting.dictionary")
    End If
    d(s)(br(i, 2)) = br(i, 3)
Next

'评估成品价值，从大到小排序
ReDim tar(1 To lr - 1, 1 To 2)
For i = 2 To UBound(ar)
    If ar(i, 2) > 0 Then
        xsum = 0
        s = ar(i, 1)
        For Each k In d(s).keys
            xsum = xsum + d(s)(k) * ljyl(k)(2)
        Next
        tar(i - 1, 1) = i
        tar(i - 1, 2) = xsum
    End If
Next

Call xSort(tar)
'Sheet2.Range("a2").Resize(UBound(tar), 2) = tar
zjz = 0

'按照成品价值，从大到小调整QTY
For i = 1 To UBound(tar)
    r = tar(i, 1)
    If r > 0 Then
        s = ar(r, 1)
        '从大到小尝试，如果料件QTY刚好=<余量，则停止
        For x = ar(r, 2) To 0 Step -1
            If check(s, x, d, ljyl) Then
                ar(r, 3) = x
                Exit For
            End If
        Next
        
        '更新料件QTY
        For Each k In d(s).keys
            t = ljyl(k)
            t(1) = t(1) + x * d(s)(k)
            ljyl(k) = t
            zjz = zjz + x * d(s)(k) * ljyl(k)(2)
        Next
    End If
Next

Sheet1.[n122] = zjz
Sheet1.[a1].CurrentRegion = ar
End Sub
Private Function check(s, x, d, ljyl) As Boolean

For Each k In d(s).keys
    t = ljyl(k)
    t(1) = t(1) + x * d(s)(k)
    If t(1) > t(0) Then
        check = False
        Exit Function
    End If
Next
check = True
End Function
Sub xSort(arr)

For i1 = 1 To UBound(arr) - 1
    For i2 = i1 + 1 To UBound(arr)
        If arr(i2, 2) > arr(i1, 2) Then
            tem = arr(i2, 2)
            arr(i2, 2) = arr(i1, 2)
            arr(i1, 2) = tem
            
            tem = arr(i2, 1)
            arr(i2, 1) = arr(i1, 1)
            arr(i1, 1) = tem
        End If
    Next
Next

End Sub

EarlGrey

yynrzwh 发表于 2025-1-9 16:47
供参考，结果和楼主不一样

谢谢，我来学习下。原先的数字是手动填写，肯定不是最优解。

kevinchengcw

没啥好方法，建模，不断优化迭代结果，基本上跑到这个量，后面的可优化空间就很小了

EarlGrey

kevinchengcw 发表于 2025-1-11 09:24
没啥好方法，建模，不断优化迭代结果，基本上跑到这个量，后面的可优化空间就很小了

能请教下建模和迭代的过程吗？

kevinchengcw

见文件，其中d5是标志位，如果大于0则解无效，b列是当前结果，c列是剩余可用量，通过修改d列添加正负值逐渐优化最终结果，d列的更优解合并到b列，再进入下一轮优化

EarlGrey

yynrzwh 发表于 2025-1-9 16:47
供参考，结果和楼主不一样

兄弟你的结果不是最优解，5楼的兄弟提供一个数据，结果更大，且仍在约束范围。可能单个因子的最优并非整体结果的最优。

EarlGrey

kevinchengcw 发表于 2025-1-13 14:17
见文件，其中d5是标志位，如果大于0则解无效，b列是当前结果，c列是剩余可用量，通过修改d列添加正负值逐渐 ...

谢谢，学习了！

kevinchengcw

这个不知道是不是极限