求助-按多条件汇总求和数据

ykcbf1100

wcj6376tcp 发表于 2024-5-18 20:16
假如同一收款人使用了不同的预算项目资金，麻烦区分一下，

你那是要增加小计了。

wcj6376tcp

baofa2 发表于 2024-5-18 20:22

非常感谢，你的拆分符合我的需求，区分类别对了的，是不是因为拆分成了很对独立的表册，数据多了运行速度稍慢，不过已经符合需求了，非常感谢

ykcbf1100

增加小计、增加合计

附件供参考。。。

ykcbf1100

增加小计和合计

1. Sub ykcbf2()  '//2024.5.19  增加小计、增加总计
   
2.     Dim arr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("资金支付查询20240517124124763")
   
9.     bt = 3: col = 25
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name Then sht.Delete
    
12.     Next
    
13.     arr = sh.UsedRange
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = arr(i, col): ss = arr(i, 32)
    
16.         If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
    
17.         If Not d(s).Exists(ss) Then Set d(s)(ss) = CreateObject("scripting.dictionary")
    
18.         d(s)(ss)(i) = i
    
19.     Next i
    
20.     On Error Resume Next
    
21.     For Each k In d.keys
    
22.         ReDim hj(1 To 2)
    
23.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
24.         sh.Copy after:=Sheets(Sheets.Count)
    
25.         Set sht = Sheets(Sheets.Count)
    
26.         m = 0
    
27.         With sht
    
28.             .Name = k
    
29.             .UsedRange.Offset(bt).ClearContents
    
30.             .DrawingObjects.Delete
    
31.             .Range("d:e,v:v").NumberFormatLocal = "@"
    
32.             For Each kk In d(k).keys
    
33.                 ReDim Sum(1 To 2)
    
34.                 For Each kkk In d(k)(kk).keys
    
35.                     m = m + 1
    
36.                     For j = 1 To UBound(arr, 2)
    
37.                         brr(m, j) = arr(kkk, j)
    
38.                     Next
    
39.                     Sum(1) = Sum(1) + brr(m, 8)
    
40.                     Sum(2) = Sum(2) + brr(m, 9)
    
41.                 Next
    
42.                 m = m + 1
    
43.                 brr(m, 8) = Sum(1): brr(m, 32) = Split(brr(m - 1, 32), "-")(1) & " 小计"
    
44.                 brr(m, 9) = Sum(2)
    
45.                 hj(1) = hj(1) + Sum(1)
    
46.                 hj(2) = hj(2) + Sum(2)
    
47.             Next
    
48.             m = m + 1
    
49.             brr(m, 8) = hj(1): brr(m, 32) = "总计"
    
50.             brr(m, 9) = hj(2)
    
51.             .[a4].Resize(m, UBound(arr, 2)) = brr
    
52.             r = .Cells(Rows.Count, col).End(3).Row
    
53.             .UsedRange.Offset(r + 2).Clear
    
54.             .Rows(3).Delete
    
55.         End With
    
56.     Next k
    
57.     sh.Activate
    
58.     Set d = Nothing
    
59.     Application.DisplayAlerts = True
    
60.     Application.ScreenUpdating = True
    
61.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
62. End Sub
    

复制代码

wcj6376tcp

ykcbf1100 发表于 2024-5-18 21:23
增加小计、增加合计

附件供参考。。。

这下按收款人拆分完全OK了，老师如果我只按预算项目代码拆分（这个需要区分支出功能分类），需要改那句代码？
Set sh = ws.Sheets("资金支付查询20240517124124763")

另外这句可否模糊一点。因为去平台导出来每次后面时间部分要变

wcj6376tcp

ykcbf1100 发表于 2024-5-18 21:23
增加小计、增加合计

附件供参考。。。

咋只有第一个表册有数据？

wcj6376tcp

ykcbf1100 发表于 2024-5-18 21:23
增加小计、增加合计

附件供参考。。。

原来后面的数据是错位的，麻烦有空的时候再看看，能不能改在前面去，谢谢！

jjmysjg

Qs18 发表于 2024-5-18 19:37
Public Sub test()
Application.ScreenUpdating = False
Dim dic As Object, arr, i, sht As Worksheet

附件是给这个楼主的吗

ykcbf1100

wcj6376tcp 发表于 2024-5-18 23:34
已经测试多次，还是只有第一个收款人有数据呢？麻烦有空的时候再看看，谢谢！

我有时间看看。

ykcbf1100

wcj6376tcp 发表于 2024-5-18 21:36
这下按收款人拆分完全OK了，老师如果我只按预算项目代码拆分（这个需要区分支出功能分类），需要改那句代 ...

如果是这样，按第一个代码修改即可，把col值改一下。