关于筛选本月、上月和上上月的数据，请帮帮忙，谢谢。

幸运方格

能力有限。只会做一点。还请各位大师相助。

蓝桥玄霜

附件不能下载，不知道为什么。

幸运方格

蓝桥玄霜 发表于 2023-2-16 18:16
附件不能下载，不知道为什么。

不好意思没有及时回复，我也不知道怎么回事，附件重新上传了。昨天一下子还发了好几个帖子。

蓝桥玄霜

筛选的例子：

grf1973

1. Sub 【分类表】统计查询()
   
2.     Dim 起始日期, 截止日期, Arr, Sl, Bf
   
3.     Dim D
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     Set Dd = CreateObject("scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     时间 = Timer
   
8.     With Sheets("打印表")
   
9.         起始日期 = .[J7].Value
   
10.         截止日期 = .[N7].Value
    
11.     End With
    
12.     If 起始日期 = "" Or 截止日期 = "" Then MsgBox "请输入日期": End
    
13.    
    
14.     上月起始 = DateSerial(Year(起始日期), Month(起始日期), 1) - 1
    
15.     上月起始 = DateSerial(Year(上月起始), Month(上月起始), 26)
    
16.     上月截止 = 起始日期 - 1
    
17.    
    
18.     上上月起始 = DateSerial(Year(上月起始), Month(上月起始), 1) - 1
    
19.     上上月起始 = DateSerial(Year(上上月起始), Month(上上月起始), 26)
    
20.     上上月截止 = 上月起始 - 1
    
21.    
    
22.    
    
23.     Arr = Sheets("=数据表=").Range("D6:Z" & Sheets("=数据表=").Range("D65536").End(xlUp).Row)
    
24.     Dim Brr(1 To 10000, 1 To 100)
    
25.     For i = 1 To UBound(Arr)
    
26.         rq = Arr(i, 5) '//日期
    
27.         If rq >= 上上月起始 And rq <= 截止日期 Then
    
28.             Xs = Arr(i, 9) & "|" & Arr(i, 10)
    
29.             Sl = Arr(i, 18) '//得量
    
30.             Bf = Arr(i, 19) '//百分比
    
31.             c = IIf(rq >= 上上月起始 And rq <= 上上月截止, 4, IIf(rq >= 上月起始 And rq <= 上月截止, 7, 10))
    
32.             If Not D.exists(Xs) Then
    
33.                 N = N + 1
    
34.                 D(Xs) = N
    
35.                 Brr(N, 1) = N
    
36.                 Brr(N, 2) = Arr(i, 9)
    
37.                 Brr(N, 3) = Arr(i, 10)
    
38.             End If
    
39.             p = D(Xs)
    
40.             Brr(p, c) = Brr(p, c) + 1
    
41.             Brr(p, c + 1) = Brr(p, c + 1) + Sl '//得量
    
42.             Brr(p, c + 2) = Brr(p, c + 2) + Bf '//百分比
    
43.         End If
    
44.     Next
    
45. 
    
46.     With Sheets("打印表")
    
47.         .Range("D11:AB" & .[D65536].End(xlUp).Row + 1).Delete Shift:=xlUp
    
48.          If N = 0 Then MsgBox "没有数据，未生成": Exit Sub
    
49.          With .Cells(11, "D").Resize(N, 15)
    
50.             .Value = Brr
    
51.             .Borders.LineStyle = 1
    
52.             .Font.Size = 11
    
53.             .HorizontalAlignment = xlCenter
    
54.          End With
    
55.     End With
    
56.    
    
57.     MsgBox "数据查询完毕！" & Chr(10) & _
    
58.            "    - 用时" & Format(Timer - 时间, "#0.0000") & "秒! -"
    
59.     Application.ScreenUpdating = True
    
60. End Sub

复制代码

grf1973

https://club.excelhome.net/forum ... ;page=1#pid11184243

边做边查资料，发到其他地方去了。

grf1973

小改一下。

幸运方格

蓝桥玄霜 发表于 2023-2-17 12:24
筛选的例子：

感谢，感谢蓝版。

幸运方格

grf1973 发表于 2023-2-17 13:39
小改一下。

非常感动，谢谢，谢谢。

幸运方格

grf1973 发表于 2023-2-17 13:39
小改一下。

帅哥，麻烦再帮忙弄个以下的效果好吗？