邯郸学步：再做递归凑数之列出开票明细

aoe1981 · 发表于 2014-10-23 23:06

哦，忽然明白了，参考循环次数的公式我搞错了：

=SUMPRODUCT(ROUNDUP(($B$2-SUM(INDIRECT("E9:E"&8+$B$3)))/INDIRECT("E9:E"&8+$B$3),),INDIRECT("E9:E"&8+$B$3)^0)

复制代码

上面的公式是求和了，没有求连续的积……
差之毫厘，谬之千里啊……

aoe1981 · 发表于 2014-10-23 23:11

本帖最后由 aoe1981 于 2014-10-23 23:14 编辑

11楼错误公式已修改：

=PRODUCT(ROUNDUP(($B$2-SUM(INDIRECT("E9:E"&8+$B$3)))/INDIRECT("E9:E"&8+$B$3),))

复制代码

三键结束。
原来，上面的对比数据，我的代码的循环次数为：1.46337E+39
啧啧，怪不得会等到花儿都谢了……
（1楼附件再次更新，增加了使用建议：循环次数大于10000000次，就建议“误差匹配”，否则可尝试“精确匹配”）

aoe1981 · 发表于 2014-10-23 23:18

　　下面是我研制这个附件的过程，这个过程中的中间结果还是很愚蠢的，但是很有意义，因为：
　　“中间结果或中间步骤最能反映思路”！！！
　　因此，自我做一个标记：
　　这就是，我一开始是用嵌套for循环4层固定解决只选择4种商品时的金额匹配问题的，以检验我的解决问题的思路是否正确、有效，在此基础上，在利用递归，抽象出共同步骤，扩展至任意n层循环的一揽子解决……
　　这些中间代码如下：
　　

'以下为开票明细（aoe1981之小学版）过渡代码：
'（普通4层循环代码，并由此步入递归）
Option Explicit
Public Sub CouShu0()
Dim n%, zje#, dj, i&, wc As Boolean, wcz#, t#
t = Timer
n = Range("b3").Value '项目数
If n = 0 Then MsgBox "请勾选项目！", , "友情提示": Exit Sub
zje = Range("b2").Value '总金额
ReDim sl&(1 To n, 1 To 1), je#(1 To n) '数量、金额
dj = Range("e9:e" & 8 + n).Value '单价
If Range("b4").Value <> "是" Then wc = False Else wc = True: wcz = Range("b5").Value
je(1) = zje - WorksheetFunction.Sum(dj)
sl(1, 1) = je(1) \ dj(1, 1)
Dim i1&, i2&, i3&, i4&, pd As Boolean, s$, gd
For i1 = sl(1, 1) To 0 Step -1
je(2) = je(1) - dj(1, 1) * i1: sl(2, 1) = je(2) \ dj(2, 1)
For i2 = sl(2, 1) To 0 Step -1
je(3) = je(2) - dj(2, 1) * i2: sl(3, 1) = je(3) \ dj(3, 1)
For i3 = sl(3, 1) To 0 Step -1
je(4) = je(3) - dj(3, 1) * i3: sl(4, 1) = je(4) \ dj(4, 1)
For i4 = sl(4, 1) To 0 Step -1
If wc Then
If Abs(je(4) - dj(4, 1) * i4) <= wcz Then pd = True: s = i1 & "-" & i2 & "-" & i3 & "-" & i4: GoTo 100
ElseIf je(4) - dj(4, 1) * i4 = 0 Then
pd = True
s = i1 & "-" & i2 & "-" & i3 & "-" & i4
GoTo 100
End If
Next i4
Next i3
Next i2
Next i1
100:
gd = Split(s, "-")
If pd Then
For i = 1 To n
sl(i, 1) = gd(i - 1) + 1
Next i
Range("f9").Resize(n) = sl
MsgBox "用时：" & Format(Timer - t, "0.0000") & "秒。", , "友情提示"
Else
MsgBox "抱歉，没有找到！", , "友情提示"
End If
End Sub

复制代码

aoe1981 · 发表于 2014-10-23 23:32

　　经过多次测试，发现一些特点以及问题：
　　1.在精确匹配下，商品单价的选择尽量不要出现小数；
　　2.商品单价的选择，最好有高有低，体现出较大的离散程度；
　　3.可能在满足上述条件的情况下，虽然预计循环次数可能依然很大，但是也是可以迅速得到精确匹配结果的，如下图：
　　 360截图-19356494.jpg

　　希望得到解决的问题：
　　1.万一在精确匹配时一时半会不成功，等候不住的时候，最好不要老是强行关闭，“结束任务”，最好是可以根据已运行时间进行强行退出！
　　其他……目前未知的……

aoe1981 · 发表于 2014-10-23 23:35

　　下图可以看出：整数结果下精确匹配的优势！
　　 360截图-19799740.jpg

香川群子 · 发表于 2014-10-24 08:25

精确匹配改为模糊匹配，只需要改为：目标值+误差范围就可以了。
我认为没啥难度。

由于原帖的要求，必须是精确匹配，所以我不认为有改成模糊匹配的需要。

…………
至于某些组合无匹配组合，或需要计算很长时间，
可以根据实际情况，设置中途退出条件、如递归计算次数达到某个数值时退出即可。

香川群子 · 发表于 2014-10-24 08:27

我在《2014新年元旦第一强帖：实用凑数凑金额高效递归剪枝算法》帖子中，
就有递归计算深度的设置。可以防止巨量计算造成的假死机出现……但显然计算对象较多时会漏过很多组合的计算。

aoe1981 · 发表于 2014-10-28 14:20

以下为递归调用1000万次没有找到精确匹配结果时强行退出的代码，大约用时40秒：

Sub DG(k%)
Dim j&, i&
If pd Then Exit Sub '找到匹配结果时直接逐层返回
cnt = cnt + 1
If cnt > 10000000 Then MsgBox "程序运行超时（" & Format(Timer - t, "0.0000") & "秒），即将强行结束，建议启用误差匹配！", , "友情提示": End
If k = n Then
For j = sl(k, 1) To 0 Step -1
If wc Then
If Abs(je(k) - dj(k, 1) * j) <= wcz Then '误差匹配
pd = True
ss(k) = j
For i = 1 To n
s = s & "-" & ss(i)
Next i
End If
Else
If je(k) - dj(k, 1) * j = 0 Then '精确匹配
pd = True
ss(k) = j
For i = 1 To n
s = s & "-" & ss(i)
Next i
End If
End If
Next j
Else
For j = sl(k, 1) To 0 Step -1
je(k + 1) = je(k) - dj(k, 1) * j '下层金额=本层金额-本层单价*本层数量
sl(k + 1, 1) = je(k + 1) \ dj(k + 1, 1) '下层数量=下层金额\下层单价
ss(k) = j
DG k + 1
Next j
End If
End Sub

复制代码

1楼附件已更新。

ly129001 · 发表于 2015-8-31 16:23

版主,求助？？{:soso_e183:}
题目：现有7根长度为1200mm的木材，需要切出相应所需长度规格，但在切断过程序中有些损耗，有效的切削长度控制在1195mm~1199mm。
求解如何才能切断出如下所需规格数量？
长度mm 数量
310             6
143          2
367       2
97          11
206          16
208          2
181 4

香川群子 · 发表于 2015-8-31 16:57

ly129001 发表于 2015-8-31 16:23
版主,求助？？
题目：现有7根长度为1200mm的木材，需要切出相应所需长度规格，但在切断过程 ...

很简单。

		自动登录	找回密码
密码			免费注册

[原创] 邯郸学步：再做递归凑数之列出开票明细

评分

点评

最新热点 /1