|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 罗达 于 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)
。这个代码与附件略有出入,条件更多一点,规则一样,是胡乱凑的,实在想不出简单的思路咯。希望有人指点,实际用时我在调整就好。
|
|