求助VBA代码装箱凑数-我写了几天也没写出这个代码，你们试试？？

Excel表哥在此

zeng3915 发表于 2025-3-29 08:23
是的，你是怎么解决呢？

规划求解               

Excel表哥在此

数据 - 规划求解：  
  

yynrzwh

ai的凑数代码，简单高效。
列出了所有组合，使用时取其一即可。

excel玉米

用网上代码拼凑了一个，凑合着用吧。借鉴了CSDN薛定谔_51大神的贴子，https://blog.csdn.net/hhhhh_51/article/details/132037091

1. Sub 凑数问题()
   
2. ' by zeng3915 https://club.excelhome.net/thread-1713384-1-2.html
   
3. Dim arr, brr(), i&, j&, s&, jj&, dc&
   
4. Dim dic As Object, rg As Range
   
5. Set dic = CreateObject("scripting.dictionary")
   
6. arr = Sheet1.UsedRange
   
7. Sheet2.Cells.Clear
   
8. Sheet2.Cells(1, 1).Resize(1, 15) = Array(arr(1, 3), arr(1, 14), arr(1, 140), arr(1, 141), arr(1, 160), "箱数", "箱数*系数", "1-5箱", "6-10箱", "11-15箱", "16-20箱", "21-25箱", "26-30箱", "31-35箱", "36-40箱")
   
9. For i = 2 To UBound(arr)
   
10.    If Len(arr(i, 14)) > 0 Then
    
11.       s = s + 1
    
12.       ReDim Preserve brr(1 To 15, 1 To s)
    
13.       brr(1, s) = arr(i, 3)     '型号
    
14.       brr(2, s) = arr(i, 14)    '待装箱数
    
15.       brr(3, s) = arr(i, 140)   '长度
    
16.       brr(4, s) = arr(i, 141)   '单个产品内含个数
    
17.       brr(5, s) = arr(i, 160)   '包装系数
    
18.       brr(6, s) = Int(arr(i, 14) / 5) '箱数
    
19.       brr(7, s) = brr(6, s) * brr(5, s) '箱数*系数
    
20.    End If
    
21. Next i
    
22. brr = Application.Transpose(brr)
    
23. Sheet2.Cells(2, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
    
24. Set rg = Sheet2.Range("A1").Resize(UBound(brr, 1) + 1, UBound(brr, 2))
    
25. rg.Sort Key1:="发货数量", Order1:=2, Header:=xlYes
    
26. arr = rg.Value
    
27. For i = 2 To UBound(arr)
    
28.     dic(i) = arr(i, 7)
    
29. Next i
    
30. dc = dic.Count
    
31.      Do    '2层do方便有符合目标值时跳出，并继续组合
    
32.          Do
    
33.             For j = 2 To dc
    
34.                 brr = combin_arr1(dic.keys, j)
    
35.                 For r = 1 To UBound(brr)
    
36.                     temp_sum = 0
    
37.                     For c = 1 To UBound(brr(r))
    
38.                         temp_sum = temp_sum + dic(brr(r)(c))
    
39.                     Next
    
40.                     If temp_sum = 56 Then
    
41.                        jj = jj + 1
    
42.                        For c = 1 To UBound(brr(r))
    
43.                            arr((brr(r)(c)), 7 + jj) = arr((brr(r)(c)), 6)
    
44.                            dic.Remove brr(r)(c)  '写入箱号，删除行号
    
45.                         Next
    
46.                         Exit Do
    
47.                     End If
    
48.                  Next
    
49.              Next
    
50.              If dc = dic.Count Then Exit Do  '无组合符合目标值，跳出
    
51.          Loop Until dc = 0
    
52.          If dc = dic.Count Then Exit Do
    
53.          dc = dic.Count
    
54.      Loop Until dc = 0
    
55. jj = jj + 1
    
56. For r = 1 To UBound(brr)
    
57.     For c = 1 To UBound(brr(r))
    
58.         arr((brr(r)(c)), 7 + jj) = arr((brr(r)(c)), 6)
    
59.     Next c
    
60. Next r
    
61. With Sheet2
    
62.    .UsedRange.Offset(1, 0).Clear
    
63.    .Cells(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
64.    rg.Sort Key1:="产品型号", Order1:=1, Header:=xlYes
    
65.    r = .Cells(65536, 1).End(xlUp).Row
    
66.    For j = 8 To 15
    
67.       s = 0
    
68.       For i = 2 To r
    
69.            If .Cells(i, j) > 0 Then
    
70.               s = s + .Cells(i, j) * .Cells(i, 5)
    
71.            End If
    
72.             .Cells(r + 1, j) = s
    
73.        Next i
    
74.    Next j
    
75.     .Cells(r + 1, 2) = "=sum(R[-" & r & "]C:R[-1]C)"
    
76.     For j = 6 To 7
    
77.         .Cells(r + 1, j) = "=sum(R[-" & r & "]C:R[-1]C)"
    
78.     Next j
    
79.     Set rg = rg.Resize(rg.Rows.Count + 1, rg.Columns.Count)
    
80.     With rg
    
81.        .Borders.LineStyle = 1   '划框线
    
82.     End With
    
83. End With
    
84. Set dic = Nothing
    
85. MsgBox "ok"
    
86. End Sub
    
87. Function combin_arr1(arr, n&)
    
88.     'arr一维数组，内含m个元素，抽取n个进行组合，返回一维嵌套数组，每行为一个组合(数组从1开始计数)
    
89.     Dim i&, j&, k&, l&, m&, kk&, t&, temp
    
90.     If LBound(arr) = 0 Then  '转为从1开始计数
    
91.         arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
    
92.     End If
    
93.     m = UBound(arr) - LBound(arr) + 1
    
94.     kk = Application.Combin(m, n): ReDim brr(1 To kk)
    
95.     If n = 1 Then
    
96.         For i = 1 To m
    
97.             brr(i) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Array(arr(i))))
    
98.         Next
    
99.         combin_arr1 = brr: Exit Function
    
100.     End If
     
101.    
     
102.     ReDim a&(1 To n), b(1 To n)
     
103.     For j = 1 To n - 1
     
104.         a(j) = j
     
105.     Next
     
106.    
     
107.     i = n - 1: k = 0 ': j = n  '上面for结束后j=n，加不加j = n都一样
     
108.     Do
     
109.         For i = a(n - 1) + 1 To m  '仅修改最后一位
     
110.             a(n) = i
     
111.             For l = 1 To n
     
112.                 b(l) = arr(a(l))
     
113.             Next
     
114.             k = k + 1: brr(k) = b
     
115.         Next
     
116.         If a(n - 1) <> a(n) - 1 And a(n) = m Then
     
117.             a(n - 1) = a(n - 1) + 1
     
118.         ElseIf a(n - 1) = a(n) - 1 And a(n) = m Then
     
119.             For t = n - 1 To 1 Step -1      'a(j)进步，避免n=2情况报错，因而只n-1
     
120.                 If a(t) <> a(t + 1) - 1 Then
     
121.                     temp = a(t) + 1: a(t) = temp: t = t + 1
     
122.                     Do Until t = n          '为真退出，先判断；最后一位不修改
     
123.                         a(t) = a(t - 1) + 1: t = t + 1
     
124.                     Loop
     
125.                     Exit For
     
126.                 End If
     
127.             Next
     
128.         End If
     
129.     Loop Until k = kk
     
130.     combin_arr1 = brr
     
131. End Function

复制代码