宁静的夏天 天空中繁星点点 心里头有些思念 思念着你的脸……
我们今天分享的内容目的只有一个，就是凑数。
当然，不是滥竽充数的凑数，而是科学发展观指导下的……凑数~好吧，反正就是凑数……
举个例子，还是。
![]()
如上图所示。A列是发票号，B列是发票金额，假设你有一笔汇款，不多，也就五百万……美金而已……
现在你想知道这五百万美金是由哪些发票金额组成的？
很久以前，我们在另外一个公众号分享了规划求解的方案，参考链接：聊下如何用【规划求解】计算总和为某个值的组合
规划求解的方案有很多好处，当然，也有很多缺点。本着君子坦荡荡的胸怀，咱们这里就只说坏处呗，比如说，这家伙只能得出一个解，甚至很多时候磨磨唧唧半天，还得不出一个解，或者得出一个错误解……
嘿，何不用VBA呢？
来个图，一键得解……吼~就是这么爽利~
![]()
如图所示，A列为发票号，B列为发票金额，D1单元格为目标合计值，D2单元格为求解的个数。
求解的个数可以设置为一个，也可以是多个，或者所有解……
代码如下：
Sub MatchNum() Dim arr, brr, i&, j&, k&, n&, mb, sl mb = [e1].Value: sl = [e2].Value arr = Range("b2:b" & Cells(Rows.Count, 1).End(3).Row) '金额装入数组arr ReDim brr(0 To 1) '存放遍历组合的数组 [g:i].ClearContents [g1:i1] = [{"方案","金额组合"，"票号"}] k = 0 For i = 1 To UBound(arr) For j = 0 To k k = k + 1 ReDim Preserve brr(0 To k) brr(k) = brr(j) & "+" & arr(i, 1) '利用结果数组brr错位引用，遍历所有组合，使用加号相连 If Evaluate(brr(k)) = mb Then '使用Evaluate函数计算表达式 n = n + 1 Cells(n + 1, 7) = "解法" & n Cells(n + 1, 8) = brr(k) If n >= sl Then Exit Sub '如果达到目标组合数量则退出程序 End If Next Next If n = 0 Then MsgBox "无解" Erase brrEnd SubSub GetNumBanks1() Dim d1 As Object, d2 As Object Dim arr, brr, i&, j&, k&, s$, r Dim rng As Range, strKey$ Set d1 = CreateObject("scripting.dictionary") Set d2 = CreateObject("scripting.dictionary") Call MatchNum arr = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row) For i = 1 To UBound(arr) If Not d1.exists(arr(i, 2)) Then '如果字典不存在该数值 d1(arr(i, 2)) = 1 '装入第一个字典，数值作为key，出现的次数作为item d2(arr(i, 2) & "@1次") = arr(i, 1) '数值和数值出现的次数合并后作为key，将发票号作为item Else d1(arr(i, 2)) = d1(arr(i, 2)) + 1 '累加数值出现的次数 strKey = arr(i, 2) & "@" & d1(arr(i, 2)) & "次" d2(strKey) = arr(i, 1) '数值和数值出现的次数合并后作为key，将发票号作为item End If Next Set rng = Range("h2:i" & Cells(Rows.Count, "h").End(xlUp).Row) brr = rng.Value For i = 1 To UBound(brr) r = Split(brr(i, 1), "+") '按分隔符+拆分取出数值明细 d1.RemoveAll '清空d1字典 s = "" For j = 0 To UBound(r) If Not d1.exists(r(j)) Then d1(r(j)) = 1 '在d1字典记录出现次数 If d2.exists(r(j) & "@1次") Then s = s & "/" & d2(r(j) & "@1次") '从d2字典取出对应数值次数的发票号 Else d1(r(j)) = d1(r(j)) + 1 '累加数值出现的次数 strKey = r(j) & "@" & d1(r(j)) & "次" If d2.exists(strKey) Then '取对应数值出现次数的发票号 s = s & "/" & d2(strKey) End If End If Next brr(i, 2) = s Next rng.ClearContents: rng = brr Set d1 = Nothing: Set d2 = Nothing Erase arr: Erase brrEnd Sub
不过话说回来，这代码当然也不是万能的，代码使用了数组错位引用的方式遍历所有组合，占用了太多内存空间，而Excel能使用的内存空间又是非常有限的……
所以当B列的数值，稍多，比如30个左右，而求解的个数又设置为所有时，程序必然会卡死，毕竟遍历的组合可能极其多，32个数据的组合就可以达到2^32，也就是42亿之多………我们的电脑声明不了如此大的数组的。
怎么解决呢？
一种方法是放弃占用空间的第二数组，改用递归，这个我们以后会聊到。
还一种看运气的方法是建议求解的个数设置一下，比如一个……嗯，没别的要说的了。
关于代码……已经有注释了，其实核心是遍历数字的组合，也就是下面这句，类似于函数公式中的错位引用，多运行几次代码应该也就明白了。
brr(k) = brr(j) & "+" & arr(i, 1)
OVER~
文件下载：https://pan.baidu.com/s/1tk4XRqIeTGxn3GuD-ZX1Cw 提取码：345s
|
|
转播
