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

ykcbf1100

limonet 发表于 2024-5-18 19:58
最主要是怕猜错。

是的，有很多不确定因素。如果靠猜的话，太浪费时间。

wcj6376tcp

ykcbf1100 发表于 2024-5-18 19:59
是的，有很多不确定因素。如果靠猜的话，太浪费时间。

对应行筛选过去后添加一行合计实际支付金额啊

ykcbf1100

wcj6376tcp 发表于 2024-5-18 20:12
对应行筛选过去后添加一行合计实际支付金额啊

这个可以有。
我写一个试试。

wcj6376tcp

ykcbf1100 发表于 2024-5-18 19:53
与原表结构相同不太好处理，因为支付申请号、支付凭证号、申请日期，这些无法合并的。感觉你自己也没有想 ...

对就是拆分到收款人工作表后合计一下金额就行

wcj6376tcp

ykcbf1100 发表于 2024-5-18 20:13
这个可以有。
我写一个试试。

假如同一收款人使用了不同的预算项目资金，麻烦区分一下，

baofa2

猜不对就算了.zip (50.15 KB, 下载次数: 8)

2024-5-18 20:26 上传

点击文件名下载附件

quqiyuan

参与一下

quqiyuan

代码：

1. Sub test()
   
2. Application.ScreenUpdating = 0
   
3. Set sht = ThisWorkbook.Sheets("资金支付查询20240517124124763")
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. arr = sht.UsedRange
   
7. For i = 4 To UBound(arr)
   
8.     If arr(i, 25) <> "" Then d(arr(i, 25)) = ""
   
9. Next
   
10. 
    
11. For Each Key In d.keys
    
12.     ReDim brr(1 To 10000, 1 To 3)
    
13.     n = 1
    
14.     brr(n, 1) = arr(2, 25)
    
15.     brr(n, 2) = arr(2, 32)
    
16.     brr(n, 3) = arr(2, 9)
    
17.     For i = 4 To UBound(arr)
    
18.         ss = arr(i, 25)
    
19.         If Key = ss And ss <> "" Then
    
20.         s = arr(i, 25) & arr(i, 32)
    
21.             If Not d1.exists(s) Then
    
22.                 n = n + 1
    
23.                 d1(s) = n
    
24.                 brr(n, 1) = arr(i, 25)
    
25.                 brr(n, 2) = arr(i, 32)
    
26.                 brr(n, 3) = arr(i, 9)
    
27.             Else
    
28.                 m = d1(s)
    
29.                 brr(m, 3) = brr(m, 3) + arr(i, 9)
    
30.             End If
    
31.         End If
    
32.     Next
    
33.     With ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(Sheets.Count))
    
34.         s = Key & " " & Format(Now, "dd日 hh时mm分")
    
35.         If Len(s) > 31 Then Key = Left(s, 20): s = Key & " " & Format(Now, "dd日 hh时mm分")
    
36.         .Name = s
    
37.         .[a1].Resize(n, 3) = brr
    
38.         .UsedRange.HorizontalAlignment = xlCenter
    
39.         .UsedRange.Borders.LineStyle = 1
    
40.         .UsedRange.Columns.AutoFit
    
41.     End With
    
42.     d1.RemoveAll
    
43. Next
    
44. Set d = Nothing
    
45. Set d1 = Nothing
    
46. Beep
    
47. Application.ScreenUpdating = 1
    
48. End Sub

复制代码

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.18
   
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)
    
16.         If Not d.Exists(s) Then
    
17.             Set d(s) = CreateObject("scripting.dictionary")
    
18.         End If
    
19.         d(s)(i) = Application.Index(arr, i)
    
20.     Next i
    
21.     For Each k In d.keys
    
22.         If k <> Empty Then
    
23.             sh.Copy after:=Sheets(Sheets.Count)
    
24.             Set sht = Sheets(Sheets.Count)
    
25.             m = d(k).Count
    
26.             With sht
    
27.                 .Name = k
    
28.                 .UsedRange.Offset(m + bt + 1).Clear
    
29.                 .UsedRange.Offset(bt).ClearContents
    
30.                 .DrawingObjects.Delete
    
31.                 .Columns("d:e").NumberFormatLocal = "@"
    
32.                 .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
33.                 r = .Cells(Rows.Count, 1).End(3).Row
    
34.                 .Cells(r + 1, 1) = "合计"
    
35.                 .Cells(r + 1, 8).Resize(1, 2).FormulaR1C1 = "=SUM(R4C:R" & "[-1]C)"
    
36.                 .Rows(3).Delete
    
37.             End With
    
38.         End If
    
39.     Next k
    
40.     sh.Activate
    
41.     Set d = Nothing
    
42.     Application.DisplayAlerts = True
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
45. End Sub
    
46. 
    
47. 
    

复制代码