2014新年元旦第一强帖：实用凑数凑金额高效递归剪枝算法

南湖的清晨 · 发表于 2014-10-18 14:56

楼主在吗？请告之联系方式，有事请教，必谢！

南湖的清晨 · 发表于 2014-10-18 16:15

求楼主联系方式

qinhuan66 · 发表于 2014-10-27 17:19

香川群子发表于 2014-3-31 00:41
这个例子就是从一堆数中抽取符合条件的组合，直到剩余元数无法满足求和条件时停止。

但显然这样得到的结 ...

香川群子老师：我想增加一列日期，但不懂得改你的代码。能否帮处理一下。在此先谢谢了

凑金额.zip (29.79 KB, 下载次数: 47)

qinhuan66 · 发表于 2014-10-27 21:05

本帖最后由 qinhuan66 于 2014-10-27 21:06 编辑

改了一下还是不行呢。

Dim sj1, sj(), jg(), d&, l&, h&, h2&, m&, n&, n2&, k&, cnt&
Sub kagawa_22()
tms = Timer
d = [H3]: l = [H6]: If l = 0 Then l = 65535
h = [H1] * 10 ^ d: h2 = [h2] * 10 ^ d: If h2 > h Then h2 = h2 - h
m = [C1].End(4).Row - 1
[a2:a65536] = "": [a2] = 1: [a2].Resize(m).DataSeries Rowcol:=xlColumns
n = [H4]: n2 = [H5]: If n2 = 0 Then If n = 0 Then n2 = m Else n2 = n
[a2].Resize(m, 5).Sort [D2], 1, , , , , , 2
sj0 = [a2].Resize(m, 4)
sj1 = [a2].Resize(m, 7)
For i = 1 To m
sj1(i, 1) = "+A" & sj1(i, 1) 'Row
sj1(i, 3) = "+" & sj1(i, 3) 'Code
sj1(i, 4) = "+" & sj1(i, 4) 'Val
sj1(i, 5) = "" 'Chk
sj1(i, 6) = i 'i
sj1(i, 7) = sj1(i, 4) * 10 ^ d 'Val2
Next
ReDim jg(l, 5): jg(0, 0) = "序号": jg(0, 1) = "组合号": jg(0, 2) = "目标金额": jg(0, 3) = "金额组合": jg(0, 4) = "所在单元格": jg(0, 5) = "单位名称组合"
k = 0: cnt = 0
For j = 1 To l
l = 0
ReDim sj(m, 1 To 8): m = 0
For i = 1 To UBound(sj1)
If sj1(i, 4) = "" Then
m = m + 1
sj(m, 1) = sj1(i, 1) 'Row
sj(m, 3) = sj1(i, 3) 'Code
sj(m, 4) = sj1(i, 4) 'Val
sj(m, 5) = sj1(i, 5) 'Chk
sj(m, 6) = sj1(i, 6) 'i
sj(m, 7) = sj1(i, 7) 'Val2
sj(m, 8) = sj(m - 1, 8) + sj(m, 7) 'Σ
End If
Next
Call dgH22(h, "", "", "", "", m + 1, 1)
' [a2].Resize(m, 4) = sj1
If k < j Then Exit For
Next
If k And k < 65535 Then [K1].CurrentRegion = "": [K1].Resize(k + 1, 6) = jg
[H7] = cnt
[H8] = Format(Timer - tms, "0.000s")
MsgBox "Result: " & k & "/ Calc " & cnt & " Time: " & Format(Timer - tms, "0.000s")
m = UBound(sj0)
[a2].Resize(m, 5) = sj1
[a2].Resize(m, 4) = sj0
[a2].Resize(m, 5).Sort [D2], 1, [a2], , 1, , , 2
End Sub
Sub dgH22(r&, ri$, ra$, rc$, rv$, i&, t&)
Dim j&, t1&, r2&
If l Then Exit Sub
cnt = cnt + 1
If t >= n And t <= n2 Then
r2 = r + h2
For j = 1 To i - 1
t1 = sj(j, 7)
If r <= t1 And t1 <= r2 Then
k = k + 1
jg(k, 0) = k
jg(k, 1) = t
jg(k, 2) = (h - r + sj(j, 6)) * 10 ^ -d
jg(k, 3) = rv & sj(j, 3)
jg(k, 4) = ra & sj(j, 1)
jg(k, 5) = rc & sj(j, 2)
x = Split(ri & "," & j, ",")
For l = 1 To UBound(x)
sj1(sj(x(l), 5), 4) = k
Next
Exit Sub
ElseIf t1 > r2 Then
Exit For
End If
Next
End If
If t = n2 Then Exit Sub
For j = i - 1 To 2 Step -1
If sj(j, 6) < r + h2 Then
If sj(j, 7) < r Then
Exit For
Else
Call dgH42(r - sj(j, 6), ri & "," & j, ra & sj(j, 1), rc & sj(j, 2), rv & sj(j, 3), j, t + 1)
End If
End If
Next
End Sub

复制代码

reign · 发表于 2014-10-28 14:01

这...这...这哪是强帖，明明是神器呀！

legend127 · 发表于 2014-10-28 23:41

香老师你的凑数法真是太强大了。真是我们做财务的福星。在此我代表我们财务人员谢谢你。并祝你越来越年轻漂亮。越来越多精华贴给我们学习。

香川群子 · 发表于 2014-10-29 08:37

qinhuan66 发表于 2014-10-27 17:19
香川群子老师：我想增加一列日期，但不懂得改你的代码。能否帮处理一下。在此先谢谢了

你的问题、要求是什么？

一、如果只是增加了1列日期，但这个日期不需要参与运算，
那么就只需要更改数据取值范围和结果输出范围即可。是这样子吗？

二、如果这个日期需要在输出时体现出来……那么有输出结果的例子吗？

qinhuan66 · 发表于 2014-10-29 12:44

香川群子发表于 2014-10-29 08:37
你的问题、要求是什么？

一、如果只是增加了1列日期，但这个日期不需要参与运算，

谢谢香老师今天上午停电所以没看到你的回复。
我的想法是做成像你在其他网站做的一个附件那样（下图）
你在其他网站的附件：

例子.rar (20.31 KB, 下载次数: 52)
QQ图片20141029122850.jpg

需要提取部分还是不变（下图）
QQ图片20141029123311.jpg

本次需要做的附件：

求助.rar (26.75 KB, 下载次数: 25)

谢谢

qinhuan66 · 发表于 2014-10-29 16:32

qinhuan66 发表于 2014-10-29 12:44
谢谢香老师今天上午停电所以没看到你的回复。
我的想法是做成像你在其他网站做的一个附件那样（下图） ...

香老师有一个问题（如下图），凑合金额能否优先按A列（日期多的情况）相同的日期先组合后，（例如：有9月23日，9月24日，9月25日，先在9月23日找组合，然后再到9月24日）谢谢

qinhuan66 · 发表于 2014-10-29 21:10

你好!香老师能否抽空帮我看一下108楼的求助附件。谢谢

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

[原创] 2014新年元旦第一强帖：实用凑数凑金额高效递归剪枝算法

评分

评分