自动生成匹配的组合

zgand

初学VBA，解决工作中的重复劳动。现在碰到一个实际问题，能力有限，寻求大神帮助。

要求：给定一个负值数，求列表中 数量*金额 的积 求和后等于指定数值，数量的绝对值不能超出列表中数量，满足条件取最小组合。
求模块代码

chxw68

1. Dim sj As Variant, jg() As Variant, k%, sz!, m%
   
2. Sub test()
   
3.   Dim r%, i%
   
4.   Dim arr, brr
   
5.   With Worksheets("sheet1")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     arr = .Range("a2:b" & r)
   
8.     sz = Abs(.Range("e3"))
   
9.     ReDim sj(1 To Application.Sum(Application.Index(arr, 0, 1)), 1 To 3)
   
10.     m = 0
    
11.     For i = 1 To UBound(arr)
    
12.       For j = 1 To arr(i, 1)
    
13.         If j * arr(i, 2) <= Abs(sz) Then
    
14.           m = m + 1
    
15.           sj(m, 1) = -1 * j
    
16.           sj(m, 2) = arr(i, 2)
    
17.           sj(m, 3) = j * arr(i, 2)
    
18.         Else
    
19.           Exit For
    
20.         End If
    
21.       Next
    
22.     Next
    
23.     k = 0
    
24.     ReDim jg(1 To 10000, 1 To 1)
    
25.     dg "", 1, 0, 1
    
26.     .Columns(7).ClearContents
    
27.     If k > 0 Then
    
28.       .Range("g1").Resize(k, UBound(jg, 2)) = jg
    
29.     End If
    
30.   End With
    
31. End Sub
    
32. Sub dg(ss$, n%, he!, j%)
    
33.   If he + sj(j, 3) = sz Then
    
34.     k = k + 1
    
35.     jg(k, 1) = ss & "(" & sj(j, 1) & "*" & sj(j, 2) & ")=" & -1 * sz
    
36.   End If
    
37.   If j < m And n <= 2 Then
    
38.     If he + sj(j, 3) < sz Then
    
39.       dg ss & "(" & sj(j, 1) & "*" & sj(j, 2) & ")+", n + 1, he + sj(j, 3), j + 1
    
40.     End If
    
41.     dg ss, n, he, j + 1
    
42.   End If
    
43. End Sub
    

复制代码

chxw68

练习用递归写的，不太完善，不保证在其他数据里正常运行，供参考吧。

zgand

chxw68 发表于 2021-8-27 16:58

虽然看不懂，但完全满足要求，非常感谢

chxw68

又修改了一下。

zgand

chxw68 发表于 2021-8-28 10:14
又修改了一下。

给定的数值超出2100，程序会溢出报错，自己加了个if语句，移植到实际工作表中，运行正常