ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
12
返回列表 发新帖
楼主: 罗达

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

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-2 11:08 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
jsgj2023 发表于 2020-2-1 21:14
我有个给定金额,开出最少发票的代码,不知对你是否有用?

版主大大,求分享,我借鉴借鉴

TA的精华主题

TA的得分主题

发表于 2020-2-4 10:38 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
附件仅供参考!

最少发票拆分.rar

19.47 KB, 下载次数: 33

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-2-4 10:42 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-2-4 12:51 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. Option Explicit

  2. Dim arrResult As Variant, lngCurRowID As Long
  3. Dim dblTaxRate As Double '税率
  4. Dim dblUpperLimit As Double '上限额度

  5. Sub Test()
  6.     Dim shData As Worksheet, shResult As Worksheet
  7.     Dim arrData As Variant, lngRows As Long
  8.    
  9.     Set shData = Sheets("数据源")
  10.     Set shResult = Sheets("开票")
  11.    
  12.     dblTaxRate = shResult.Range("B1").Value
  13.     dblUpperLimit = shResult.Range("E1").Value
  14.    
  15.     arrData = shData.UsedRange
  16.     '按最大金额计算结果行数
  17.     lngRows = UBound(arrData) * (Application.WorksheetFunction.Max(shData.Range("E:E")) / dblUpperLimit)

  18.     ReDim arrResult(1 To lngRows, 1 To 6)
  19.     lngCurRowID = 1
  20.    
  21.     WriteInvoice arrData, 2, 0, 1, dblUpperLimit

  22.     shResult.Range("A3").Resize(lngCurRowID, 6) = arrResult
  23. End Sub

  24. Function WriteInvoice(arrData As Variant, RowID As Long, dblSum As Double, CardID As Long, dblMax As Double)
  25.     Dim dblCur As Double, dblUnitPrice As Double, dblWrite As Double
  26.     Dim lngCount As Long, blHasOk As Boolean
  27.    
  28.     '如果超过总行数
  29.     If RowID > UBound(arrData) Then
  30.         Exit Function
  31.     End If
  32.    
  33.     '符合条件,则计算,当前只考虑税率一个条件
  34.     If arrData(RowID, 6) = dblTaxRate Then
  35.         '取得当前含税金额、单位
  36.         dblCur = arrData(RowID, 5)
  37.         dblUnitPrice = arrData(RowID, 4)
  38.         
  39.         '如果已达到
  40.         If ((dblCur + dblSum) > dblMax) And (dblUnitPrice > 0) Then
  41.             blHasOk = True
  42.             '超出按单价计算数量,确保金额正确
  43.             lngCount = Int((dblMax - dblSum) / dblUnitPrice)
  44.             dblWrite = lngCount * dblUnitPrice
  45.             arrData(RowID, 5) = dblCur - dblWrite
  46.             
  47.             '不考虑单价,直接赋值
  48.             'dblWrite = dblMax - dblSum
  49.             'arrData(RowID, 5) = dblCur - dblWrite
  50.         Else
  51.             blHasOk = False
  52.             dblWrite = dblCur
  53.         End If
  54.         '将结果写入
  55.         If dblWrite > 0 Then RecordToResult arrData, RowID, dblWrite, CardID
  56.         
  57.         If blHasOk Then
  58.             dblSum = 0
  59.             CardID = CardID + 1 '成功则票号加1
  60.         Else
  61.             dblSum = dblSum + dblCur
  62.             RowID = RowID + 1
  63.         End If
  64.     Else
  65.         '不符合条件,处理下一行
  66.         RowID = RowID + 1
  67.     End If
  68.    
  69.     WriteInvoice arrData, RowID, dblSum, CardID, dblMax
  70. End Function

  71. Function RecordToResult(arrData As Variant, RowID As Long, dblVal As Double, CardID As Long)
  72.     arrResult(lngCurRowID, 1) = CardID
  73.     arrResult(lngCurRowID, 2) = arrData(RowID, 2)
  74.     arrResult(lngCurRowID, 3) = arrData(RowID, 3)
  75.     arrResult(lngCurRowID, 4) = arrData(RowID, 4)
  76.     arrResult(lngCurRowID, 5) = dblVal
  77.     arrResult(lngCurRowID, 6) = dblTaxRate
  78.    
  79.     '结果集,行号加1
  80.     lngCurRowID = lngCurRowID + 1
  81. End Function
复制代码

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-31 19:55 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
我写了一个简单的循环处理方式,放上来以后改进做比较
  1. Sub fenfenfen()
  2. '数组模拟法分割发票金额
  3. Dim arr, brr(), r, x, y, k, crr(), t
  4. Dim hj1, hj2, hj3, hs
  5. Dim 税率, 发票限额, 总金额, 金额列
  6. With Worksheets("当月送货情况")
  7. arr = .Range("a1").CurrentRegion
  8. 税率 = arr(5, 20)       '多税率需要输入档次税率数据,本代码忽略税率与客户单位的不同
  9. 发票限额 = 100000 * (税率 + 1)
  10. 金额列 = .Range("r1:r" & UBound(arr))
  11. 总金额 = Application.Sum(金额列)
  12. y = Application.RoundUp(总金额 / 发票限额, 0)   '开票总张数
  13. End With

  14. ReDim brr(1 To UBound(arr) - 1, 1 To y + 1)
  15. For x = 1 To y
  16.     For r = 2 To UBound(arr)
  17.         brr(r - 1, y + 1) = r
  18.         k = dj(brr, r - 1, x)
  19.         If k(1) = 发票限额 Then
  20.             brr(r - 1, x) = 0
  21.         ElseIf k(1) < 发票限额 And k(1) + arr(r, 18) - k(0) > 发票限额 Then
  22.             brr(r - 1, x) = Application.Round(发票限额 - k(1), 2)
  23.         Else
  24.             brr(r - 1, x) = Application.Round(arr(r, 18) - k(0), 2)
  25.         End If
  26.         If brr(r - 1, x) > 0 Then hs = hs + 1       '大于0则需占用打印表格一行
  27.     Next
  28. Next
  29. r = 0: x = 0: k = 0
  30. ReDim crr(1 To hs + y, 1 To 17)     '+y是加上合计占用的行数

  31. For x = 1 To y
  32.     For r = 1 To UBound(brr)
  33.         If brr(r, x) > 0 Then
  34.             t = t + 1
  35.             crr(t + k, 1) = x                '序号
  36.             crr(t + k, 2) = arr(brr(r, 6), 2) '品名
  37.             crr(t + k, 3) = arr(brr(r, 6), 7) '产地
  38.             crr(t + k, 4) = arr(brr(r, 6), 8) '规格
  39.             crr(t + k, 5) = arr(brr(r, 6), 9) '单位
  40.             crr(t + k, 6) = Application.Round(brr(r, x) / arr(brr(r, 6), 17), 2) '数量保留二位
  41.             crr(t + k, 7) = arr(brr(r, 6), 17) '含税单价
  42.             crr(t + k, 8) = brr(r, x)          '含税金额
  43.             crr(t + k, 9) = arr(brr(r, 6), 20) '税率
  44.             crr(t + k, 10) = Application.Round(brr(r, x) / (1 + arr(brr(r, 6), 20)) * arr(brr(r, 6), 20), 2) '税额
  45.             crr(t + k, 11) = Application.Round(brr(r, x) / (1 + arr(brr(r, 6), 20)), 2) '不含税金额
  46.             crr(t + k, 12) = arr(brr(r, 6), 6) '批号
  47.             crr(t + k, 13) = arr(brr(r, 6), 4) '批次
  48.             crr(t + k, 14) = arr(brr(r, 6), 3) '发货日期
  49.             'crr(t + k, 15) = arr(brr(r, 6), 2) '备注
  50.             crr(t + k, 16) = arr(brr(r, 6), 19) '收货单位
  51.             'crr(t + k, 17)                      '年月
  52.             hj1 = hj1 + crr(t + k, 8)   '合计含税金额
  53.             hj2 = hj2 + crr(t + k, 10)    '合计税额
  54.             hj3 = hj3 + crr(t + k, 11)    '合计不含税金额
  55.         End If
  56.     Next
  57.     k = k + 1
  58.     crr(t + k, 1) = "合计"
  59.     crr(t + k, 8) = hj1
  60.     crr(t + k, 10) = hj2
  61.     crr(t + k, 11) = hj3
  62.     hj1 = 0: hj2 = 0: hj3 = 0
  63. Next
  64. Worksheets("清单统计").Range("a3").Resize(UBound(crr), 17) = crr
  65. End Sub




  66. Function dj(brr As Variant, myrow As Variant, mycol As Variant)
  67. '计算当前位置发票累计金额
  68. Dim r, c
  69. Dim sumpor, sumpoc
  70. For c = 1 To mycol - 1       '同行求和
  71.     sumpor = sumpor + brr(myrow, c)
  72. Next

  73. For r = 1 To myrow - 1      '同列求和
  74.     sumpoc = sumpoc + brr(r, mycol)
  75. Next
  76. dj = Array(sumpor, sumpoc)
  77. End Function
复制代码


TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-31 20:21 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

代码写得太好了,大有收获,谢谢指导

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-1 20:43 | 显示全部楼层
最新代码
  1. Sub 整数量开票()
  2. '数量取整数
  3. Dim arr1, kh, rr, arr(1 To 10000, 1 To 17), brr(1 To 50000, 1 To 17), r, x, y, k, t
  4. Dim hj_hsje, hj_bhsje, hj_se    '合计含税金额-不含税金额-税额
  5. Dim 税率, 发票限额
  6. Dim js, nb_yu, nb_xie, nb_wc, js_fp, lj_je, js_xj   '计数-余额-写入数-误差(修正整数减少的数值)总数-发票序号-累计金额-小计行发票号

  7. arr1 = Worksheets("出库表").UsedRange
  8. With Worksheets("分割提取")
  9.     税率 = .[b2]       '税率
  10.     发票限额 = Application.RoundUp(.[f2] * (税率 + 1), 2)      '上限额度
  11.     kh = .[i2]       '客户单位
  12. '=============分割提取==============================================================
  13. '序号    品名    产地    规格    单位    数量    含税单价    含税金额    税率
  14. ' 1       2       3        4      5        6         7           8         9
  15. '税额    不含税金额  生产批号    来货批次  发货日期    备注    购货单位    年月
  16. ' 10          11        12          13        14        15        16        17
  17. '==================================================================================
  18. r = 0
  19. For k = 2 To UBound(arr1)           '将符合条件的数据装入数组
  20.     If arr1(k, 20) = 税率 And arr1(k, 21) = kh And arr1(k, 25) = "已回票" Then
  21.         r = r + 1   '计数
  22.         rr = rr & k & " "       '行号拼接
  23.         arr(r, 1) = k               '数据在excel工作表的行号
  24.         arr(r, 2) = arr1(k, 4)      '品名
  25.         arr(r, 3) = arr1(k, 6)      '产地
  26.         arr(r, 4) = arr1(k, 7)      '规格
  27.         arr(r, 5) = arr1(k, 8)      '单位
  28.         If arr(r, 5) = "kg" Then arr(r, 6) = arr1(k, 19) / arr1(k, 18) Else arr(r, 6) = Int(arr1(k, 19) / arr1(k, 18))
  29.            '数量,kg为单位的可以有零数,其他的只能整数
  30.         arr(r, 7) = arr1(k, 18)     '含税单价
  31.         arr(r, 8) = arr1(k, 19)     '含税金额
  32.         arr(r, 9) = arr1(k, 20)     '税率
  33.         arr(r, 10) = Application.Round(arr(r, 8) / (1 + arr(r, 9)) * arr(r, 9), 2)              '税额
  34.         arr(r, 11) = Application.Round(arr(r, 8) / (1 + arr(r, 9)), 2)            '不含税金额
  35.         arr(r, 12) = arr1(k, 5)     '生产批号
  36.         arr(r, 13) = arr1(k, 3)     '来货批次
  37.         arr(r, 14) = arr1(k, 2)     '发货日期
  38.         arr(r, 15) = ""             '备注28
  39.         arr(r, 16) = arr1(k, 21)    '购货单位
  40.         arr(r, 17) = ""             '年月
  41.     End If
  42. Next

  43. js = 0: nb_yu = 发票限额: nb_xie = 0: nb_wc = 0: js_fp = 1      '循环取数凑数
  44. For k = 1 To r
  45. 10000:
  46.     If arr(k, 8) <= nb_yu Then
  47.         js = js + 1     '行数
  48.         nb_xie = Application.RoundUp(arr(k, 8), 2)  '写入=总额-余额(即原数)
  49.         For y = 1 To 17
  50.             brr(js, y) = arr(k, y)
  51.         Next
  52.         brr(js, 8) = nb_xie
  53.                 '不用再计算不含税与税额等
  54.         js_xj = js_fp
  55.         brr(js, 1) = js_fp
  56.         nb_yu = Application.RoundUp(nb_yu - nb_xie, 2)
  57.         hj_hsje = hj_hsje + brr(js, 8)
  58.         hj_bhsje = hj_bhsje + brr(js, 11)
  59.         hj_se = hj_se + brr(js, 10)
  60.         If js_fp > js_xj Then
  61.             js = js + 1
  62.             brr(js, 1) = "合计"
  63.             brr(js, 8) = hj_hsje
  64.             brr(js, 10) = hj_se
  65.             brr(js, 11) = hj_bhsje
  66.             brr(js, 16) = kh
  67.             hj_hsje = 0
  68.             hj_bhsje = 0
  69.             hj_se = 0
  70.         End If
  71.     Else
  72.         js = js + 1
  73.         nb_xie = Application.RoundUp(nb_yu, 2)
  74.         For y = 1 To 17
  75.             brr(js, y) = arr(k, y)
  76.         Next
  77.         If brr(js, 5) <> "kg" Then nb_xie = Int(nb_xie / brr(js, 7)) * brr(js, 7)
  78.         brr(js, 8) = nb_xie
  79.         brr(js, 10) = Application.Round(brr(js, 8) / (1 + brr(js, 9)) * brr(js, 9), 2)
  80.         brr(js, 11) = Application.Round(brr(js, 8) / (1 + brr(js, 9)), 2)
  81.         brr(js, 6) = Application.Round(brr(js, 8) / brr(js, 7), 2)
  82.            
  83.         brr(js, 1) = js_fp
  84.         arr(k, 8) = Application.Round(arr(k, 8) - nb_xie, 2)     '累减,直到小于限额
  85.         arr(k, 10) = Application.Round(arr(k, 10) - brr(js, 10), 2)
  86.         arr(k, 11) = Application.Round(arr(k, 11) - brr(js, 11), 2)
  87.         arr(k, 6) = Application.Round(arr(k, 6) - brr(js, 6), 2)
  88.         nb_yu = Application.RoundUp(nb_yu - nb_xie, 2)
  89.         js_xj = js_fp
  90.         If nb_yu < brr(js, 7) Or nb_yu <= 0 Then
  91.             nb_yu = 发票限额
  92.             js_fp = js_fp + 1
  93.         End If
  94.         hj_hsje = hj_hsje + brr(js, 8)
  95.         hj_bhsje = hj_bhsje + brr(js, 11)
  96.         hj_se = hj_se + brr(js, 10)
  97.         
  98.         If js_fp > js_xj Then
  99.             js = js + 1
  100.             brr(js, 1) = "合计"
  101.             brr(js, 8) = hj_hsje
  102.             brr(js, 10) = hj_se
  103.             brr(js, 11) = hj_bhsje
  104.             brr(js, 16) = kh
  105.             hj_hsje = 0
  106.             hj_bhsje = 0
  107.             hj_se = 0
  108.         End If
  109.         GoTo 10000
  110.     End If
  111. Next
  112.     js = js + 1         '添加最后一项的合计
  113.     brr(js, 1) = "合计"
  114.     brr(js, 8) = hj_hsje
  115.     brr(js, 10) = hj_se
  116.     brr(js, 11) = hj_bhsje
  117.     brr(js, 16) = kh

  118. Application.ScreenUpdating = False
  119. x = .Cells(.Rows.Count, 1).End(xlUp).Row
  120. .Range("a" & x + 1).Resize(js, 17) = brr
  121. .Range("q" & x + 1).Resize(js, 1) = InputBox("请输入开票日期,默认为当前日期", "开票日期", Format(Date, "yyyy-m-d"))
  122. Application.ScreenUpdating = True
  123. End With

  124. With Worksheets("出库表")
  125. Application.EnableEvents = False
  126.     t = Split(rr, " ")
  127.     For x = 0 To UBound(t) - 1
  128.        .Range("y" & t(x)).Value = "已开票"
  129.     Next
  130. Application.ScreenUpdating = True
  131. End With

  132. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2020-5-4 17:52 | 显示全部楼层

楼主的代码怎么同附件不一致。请上传该代码的附件。以便分享。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 00:19 , Processed in 0.068646 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表