应该是最简单的发票凑数，期望递归法指导

罗达 · 发表于 2020-1-23 20:42

本帖最后由罗达于 2020-1-23 20:48 编辑

Sub 细分复合法() '用细分金额倒装如数组方法分割金额
Dim arra(), arrb(), arrk(), arrt()
Dim arr, k&, x&, y&, dic, a!, b!, c$, e!
arr = Worksheets("出库表").UsedRange
With Worksheets("分割提取")
a = .[B2] '税率
b = .[f2] '上限额度
c = .[i2] '客户单位
e = .[o2] '误差额度
End With
For k = 2 To UBound(arr) '将符合条件的数据按误差限额细分装入数组
If arr(k, 20) = a And arr(k, 21) = c And arr(k, 25) = "已回票" Then
m = Application.RoundUp(arr(k, 19) / e, 0) '细分循环次数
n = n + m
ReDim Preserve arra(1 To 3, 1 To n) '申明动态数组保留原值
i = UBound(arra, 2) '从数组最大序号开始倒序装入细分数据
'arra(1, i) = kk '发票号
arra(2, i) = k '原数据行号
If (arr(k, 19) Mod e) > 0 Then
arra(3, i) = arr(k, 19) Mod e '细分金额尾数
Else
arra(3, i) = e
End If
For x = UBound(arra, 2) - 1 To UBound(arra, 2) - m + 1 Step -1
'arra(1, i) = kk '发票号
arra(2, x) = k '原数据行号
arra(3, x) = e '细分金额
Next
End If
Next
x = 0
For x = 1 To UBound(arra, 2) '累加求得各行发票序号
j = j + arra(3, x)
If j < (b * (1 + a) * (kk + 1) - e) Then
arra(1, x) = kk + 1
ElseIf j >= (b * (1 + a) * (kk + 1) - e) Then
kk = kk + 1
arra(1, x) = kk + 1
End If
Next
Set dic = CreateObject("Scripting.Dictionary")
x = 0
For x = 1 To UBound(arra, 2)
dic(arra(1, x) & "|" & arra(2, x)) = dic(arra(1, x) & "|" & arra(2, x)) + arra(3, x)
Next
ReDim arrk(1 To dic.Count)
ReDim arrt(1 To dic.Count)
ReDim arrb(1 To dic.Count, 1 To 17)
arrk = dic.keys
arrt = dic.items
x = 0: i = 0: j = 0 '将分割结果数据补充完整放入数组arrb
For x = 0 To UBound(arrk)
i = arrk(x)
j = Right(i, Len(i) - Application.Find("|", i)) '行号
arrb(x + 1, 1) = Left(i, Application.Find("|", i) - 1) '发票号-序号
arrb(x + 1, 2) = arr(j, 4) '品名
arrb(x + 1, 3) = arr(j, 6) '产地
arrb(x + 1, 4) = arr(j, 7) '规格
arrb(x + 1, 5) = arr(j, 8) '单位
arrb(x + 1, 7) = arr(j, 18) '含税单价
arrb(x + 1, 8) = arrt(x) '含税金额
arrb(x + 1, 9) = arr(j, 20) '税率
arrb(x + 1, 6) = Application.Round(arrb(x + 1, 8) / arrb(x + 1, 7), 4) '数量
arrb(x + 1, 10) = Application.Round(arrb(x + 1, 8) / (1 + arrb(x + 1, 9)) * arrb(x + 1, 9), 2) '税额
arrb(x + 1, 11) = arrb(x + 1, 8) - arrb(x + 1, 10) '不含税金额
arrb(x + 1, 12) = arr(j, 5) '生产批号
arrb(x + 1, 13) = arr(j, 3) '来货批次
arrb(x + 1, 14) = arr(j, 2) '发货日期
arrb(x + 1, 15) = "" '备注
arrb(x + 1, 16) = c '购货单位....需换成全称
arrb(x + 1, 17) = "" '开票年月
arr(j, 25) = "已开票"
Next
Application.ScreenUpdating = False
With Worksheets("分割提取") '将分割后的完整数据写入工作表
y = .Range("a65536").End(xlUp).Row
.Range("a" & y + 1).Resize(UBound(arrb), 17) = arrb
End With
i = 0
With Worksheets("出库表") '将已开票的金额回写注明
For i = 1 To UBound(arr)
If arr(i, 25) = "已开票" Then
.Range("Y" & i) = arr(i, 25)
End If
Next
End With
Application.ScreenUpdating = True
End Sub

复制代码

有个发货记录，用其开税票。以前硬写了一个，是将金额全部分割成很小的数值，再用字典取，过程代码冗余较慢。现在想用递归写一个，请赐教。

凑数求助.zip (16.47 KB, 下载次数: 30) 。这个代码与附件略有出入，条件更多一点，规则一样，是胡乱凑的，实在想不出简单的思路咯。希望有人指点，实际用时我在调整就好。

likaiyihou · 发表于 2020-1-23 21:41

关于凑数的处理，建议你搜索一下香川裙子的一个帖子，非常棒。

罗达 · 发表于 2020-1-23 22:20

likaiyihou 发表于 2020-1-23 21:41
关于凑数的处理，建议你搜索一下香川裙子的一个帖子，非常棒。

看了香川老师的几个关于递归的帖子，看得一知半解，更是写不出来。和一般的凑数有区别，就不会改了。感谢帮助

yjh_27 · 发表于 2020-1-23 23:13

罗达发表于 2020-1-23 22:20
看了香川老师的几个关于递归的帖子，看得一知半解，更是写不出来。和一般的凑数有区别，就不会改了。感谢 ...

你这个可分割，就简单了。循环即可

zpy2 · 发表于 2020-1-24 07:54

这个多开一张，少开一张差别很大吗？

罗达 · 发表于 2020-1-24 11:33

zpy2 发表于 2020-1-24 07:54
这个多开一张，少开一张差别很大吗？

严谨、准确是公司的基本要求

罗达 · 发表于 2020-2-1 19:45

沉了，自己顶一下，期待老师指导递归写法

micch · 发表于 2020-2-1 19:56

本帖最后由 micch 于 2020-2-1 20:00 编辑

凑数的意思是，所有符合条件的数，组合在一起凑出110000的和值，尽量得到组合数最少的结果，也就是乱序凑数，

你的要求是按数据的原始顺序凑数，那第一个数只能和第2,3,4个数凑，那就不需要递归了，而且你的模拟结果，金额是可以拆分，也就是，组合的结果必然是110000，这个完全是分割而不是凑数

按你的结果，好写，不过前提是税率一致的金额都可以自由组合，这个和实际情况需要呼应才行。实际开票时，同一公司的勉强还能开一起，不同公司是不能开一起的。即使是同一公式不同订单，既然可以拆分金额，那就完全可以按总金额开票，110000一张，开到不足110000为止。

jsgj2023 · 发表于 2020-2-1 21:14

我有个给定金额，开出最少发票的代码，不知对你是否有用？

罗达 · 发表于 2020-2-2 11:06

micch 发表于 2020-2-1 19:56
凑数的意思是，所有符合条件的数，组合在一起凑出110000的和值，尽量得到组合数最少的结果，也就是乱序凑数 ...

谢谢M老师关注，正如您说的一样，实际开票有多个条件筛选（税率、客户相同）数据，顺序分割-凑数，而且还设有允许误差值，不完全是按照满值开票。其他的和您说的一样。我有一个公式版的，后改写成了更简便的V版。这次求助也是想一个更高效的思路，我发的代码效率很低。再次感谢

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

[求助] 应该是最简单的发票凑数，期望递归法指导

最新热点 /1