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

wcj6376tcp

ykcbf1100 发表于 2024-5-19 09:36
我有时间看看。

刚才下拉看见了，所有收款人都有数据，只是越往后面数据越靠下了，影响查看，麻烦修改一下，谢谢

ykcbf1100

wcj6376tcp 发表于 2024-5-19 09:48
刚才下拉看见了，所有收款人都有数据，只是越往后面数据越靠下了，影响查看，麻烦修改一下，谢谢

改好了。。。

ykcbf1100

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

Set sh = ws.Sheets("资金支付查询20240517124124763")
这一句改成这样：Set sh = ws.Sheets(1)

ykcbf1100

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

按预算项目拆分，并按支出功能分类汇总。

ykcbf1100

按预算项目拆分

1. Sub ykcbf()  '//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(1)        '//主表
   
9.     bt = 3      '//标题行数
   
10.     col = 32    '//拆分字段列号
    
11.     col1 = 31   '//分类汇总字段列号
    
12.     For Each sht In Sheets
    
13.         If sht.Name <> sh.Name Then sht.Delete
    
14.     Next
    
15.     arr = sh.UsedRange
    
16.     For i = bt + 1 To UBound(arr)
    
17.         s = arr(i, col): ss = arr(i, col1)
    
18.         If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
    
19.         If Not d(s).Exists(ss) Then Set d(s)(ss) = CreateObject("scripting.dictionary")
    
20.         d(s)(ss)(i) = i
    
21.     Next i
    
22.     On Error Resume Next
    
23.     For Each k In d.keys
    
24.         ReDim hj(1 To 2)
    
25.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
26.         sh.Copy after:=Sheets(Sheets.Count)
    
27.         Set sht = Sheets(Sheets.Count)
    
28.         m = 0
    
29.         With sht
    
30.             .Name = k
    
31.             .UsedRange.Offset(bt).ClearContents
    
32.             .DrawingObjects.Delete
    
33.             .Range("d:e,v:v").NumberFormatLocal = "@"
    
34.             For Each kk In d(k).keys
    
35.                 ReDim Sum(1 To 2)
    
36.                 For Each kkk In d(k)(kk).keys
    
37.                     m = m + 1
    
38.                     For j = 1 To UBound(arr, 2)
    
39.                         brr(m, j) = arr(kkk, j)
    
40.                     Next
    
41.                     Sum(1) = Sum(1) + brr(m, 8)
    
42.                     Sum(2) = Sum(2) + brr(m, 9)
    
43.                 Next
    
44.                 m = m + 1
    
45.                 brr(m, 8) = Sum(1): brr(m, col1) = Split(brr(m - 1, col1), "-")(1) & " 小计"
    
46.                 brr(m, 9) = Sum(2)
    
47.                 hj(1) = hj(1) + Sum(1)
    
48.                 hj(2) = hj(2) + Sum(2)
    
49.             Next
    
50.             m = m + 1
    
51.             brr(m, 8) = hj(1): brr(m, col1) = "总计"
    
52.             brr(m, 9) = hj(2)
    
53.             .[a4].Resize(m, UBound(arr, 2)) = brr
    
54.             r = .Cells(Rows.Count, col).End(3).Row
    
55.             .UsedRange.Offset(r + 2).Clear
    
56.             .Rows(3).Delete
    
57.         End With
    
58.     Next k
    
59.     sh.Activate
    
60.     Set d = Nothing
    
61.     Application.DisplayAlerts = True
    
62.     Application.ScreenUpdating = True
    
63.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
64. End Sub
    

复制代码

wcj6376tcp

ykcbf1100 发表于 2024-5-19 10:26
按预算项目拆分

现在非常好了。今天只有一朵花了，改天再来送花

baofa2

wcj6376tcp 发表于 2024-5-19 11:19
现在非常好了。今天只有一朵花了，改天再来送花

工作表名不可超31字符，请注意  On Error Resume Next  这个写法带来的欺骗。

wcj6376tcp

这个我已经用  .Name = Split(k, "-")(1) 只取-后面的部分解决了

baofa2

wcj6376tcp 发表于 2024-5-19 13:05
这个我已经用  .Name = Split(k, "-")(1) 只取-后面的部分解决了