多条件跨工作表求和的问题，请赐教，谢谢！

fwa103

按照标黄色条件：年，月，销项统计对应查询“销项统计”表，进项统计对应查询“进项统计加旅客运输”表，去重后的项目名称在B4列按升序罗列，去重后的税率按照从大到小的顺序在C3往右罗列

例如：2024年1月销项统计查询：在“销项统计”表中查找入账日期为2024年1月的数据，按照对应的项目名称、税率汇总相加税额。
2024年1月进项统计查询：在“进项统计”和“旅客运输”表查找对应入账日期的数据，按照对应的项目名称、税率汇总相加税额。税率最后添加一个“转出”统计“进项统计”表中转出一列为”是“的对应项目名称所有税率的税额合计。

请大神赐教，感谢！

fwa103

请老师们赐教，感谢！

ykcbf1100

就是费时，得写二个统计代码。

冰封气流

建议找个淘宝店，付费搞定，好歹你自己写点，有问题啥的大家给你修改，上来就白嫖，不太好吧

ykcbf1100

参与一下，目前完成销项统计

1. Sub ykcbf()  '//2024.1.24
   
2.     Dim arr, brr, d, zrr
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     Set List = CreateObject("System.Collections.ArrayList")
   
8.     Set sh = ThisWorkbook.Sheets("查询")
   
9.     With sh
   
10.         nf = .[c2]: yf = .[e2]: xm = .[g2]
    
11.     End With
    
12.     Select Case xm
    
13.         Case Is = "销项统计"
    
14.             With Sheets(xm)
    
15.                 r = .Cells(Rows.Count, 1).End(3).Row
    
16.                 arr = .Range("a1:l" & r)
    
17.                 List.Clear
    
18.                 For i = 4 To UBound(arr)
    
19.                     rq = arr(i, 6)
    
20.                     If Year(rq) = nf And Month(rq) = yf Then
    
21.                         s = arr(i, 2)
    
22.                         d1(s) = ""
    
23.                         s = arr(i, 9)
    
24.                         If Not List.Contains(s) Then List.Add s
    
25.                         s = arr(i, 2) & "|" & arr(i, 9)
    
26.                         d(s) = d(s) + arr(i, 11)
    
27.                     End If
    
28.                 Next
    
29.                 List.Sort
    
30.                 List.Reverse
    
31.                 ReDim brr(1 To d1.Count, 1 To 2)
    
32.                 m = 0
    
33.                 For Each k In d1.keys
    
34.                     m = m + 1
    
35.                     brr(m, 1) = m
    
36.                     brr(m, 2) = k
    
37.                 Next
    
38.                 With sh
    
39.                     .[a4:j10000] = ""
    
40.                     .[c3:j3] = ""
    
41.                     .[a4].Resize(m, 2) = brr
    
42.                     .[c3].Resize(1, List.Count) = List.toArray
    
43.                     .Cells(3, List.Count + 3) = "转出"
    
44.                     arr = .[a3].Resize(d1.Count + 1, List.Count + 2)
    
45.                     For i = 2 To UBound(arr)
    
46.                         For j = 3 To UBound(arr, 2)
    
47.                             s = arr(i, 2) & "|" & arr(1, j)
    
48.                             arr(i, j) = d(s)
    
49.                         Next
    
50.                     Next
    
51.                     .[a3].Resize(d1.Count + 1, List.Count + 2) = arr
    
52.                     .[a3].Resize(d1.Count + 1, List.Count + 2).Borders.LineStyle = 1
    
53.                 End With
    
54.             End With
    
55.         Case Is = "进项统计"
    
56.             
    
57.         Case Else
    
58.             Exit Sub
    
59.     End Select
    
60.     Set d = Nothing
    
61.     Set d1 = Nothing
    
62.     Application.ScreenUpdating = True
    
63.     MsgBox "OK！"
    
64. End Sub
    

复制代码

ykcbf1100

已全部完成，附件已更新。

fwa103

ykcbf1100 发表于 2024-1-24 09:29
比较费时，目前完成了销项统计。

非常感谢！耽误您时间，让您受累了

ykcbf1100

全部完成了

ykcbf1100

附件供参考。

如果运行出现错误提示，请系统安装net.Framework 3.5以上版本

fwa103

ykcbf1100 发表于 2024-1-24 09:55
附件供参考。

如果运行出现错误提示，请系统安装net.Framework 3.5以上版本

非常感谢！！！正是需要的