|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub 【分类表】统计查询()
- Dim 起始日期, 截止日期, Arr, Sl, Bf
- Dim D
- Set D = CreateObject("scripting.dictionary")
- Set Dd = CreateObject("scripting.dictionary")
- Application.ScreenUpdating = False
- 时间 = Timer
- With Sheets("打印表")
- 起始日期 = .[J7].Value
- 截止日期 = .[N7].Value
- End With
- If 起始日期 = "" Or 截止日期 = "" Then MsgBox "请输入日期": End
-
- 上月起始 = DateSerial(Year(起始日期), Month(起始日期), 1) - 1
- 上月起始 = DateSerial(Year(上月起始), Month(上月起始), 26)
- 上月截止 = 起始日期 - 1
-
- 上上月起始 = DateSerial(Year(上月起始), Month(上月起始), 1) - 1
- 上上月起始 = DateSerial(Year(上上月起始), Month(上上月起始), 26)
- 上上月截止 = 上月起始 - 1
-
-
- Arr = Sheets("=数据表=").Range("D6:Z" & Sheets("=数据表=").Range("D65536").End(xlUp).Row)
- Dim Brr(1 To 10000, 1 To 100)
- For i = 1 To UBound(Arr)
- rq = Arr(i, 5) '//日期
- If rq >= 上上月起始 And rq <= 截止日期 Then
- Xs = Arr(i, 9) & "|" & Arr(i, 10)
- Sl = Arr(i, 18) '//得量
- Bf = Arr(i, 19) '//百分比
- c = IIf(rq >= 上上月起始 And rq <= 上上月截止, 4, IIf(rq >= 上月起始 And rq <= 上月截止, 7, 10))
- If Not D.exists(Xs) Then
- N = N + 1
- D(Xs) = N
- Brr(N, 1) = N
- Brr(N, 2) = Arr(i, 9)
- Brr(N, 3) = Arr(i, 10)
- End If
- p = D(Xs)
- Brr(p, c) = Brr(p, c) + 1
- Brr(p, c + 1) = Brr(p, c + 1) + Sl '//得量
- Brr(p, c + 2) = Brr(p, c + 2) + Bf '//百分比
- End If
- Next
- With Sheets("打印表")
- .Range("D11:AB" & .[D65536].End(xlUp).Row + 1).Delete Shift:=xlUp
- If N = 0 Then MsgBox "没有数据,未生成": Exit Sub
- With .Cells(11, "D").Resize(N, 15)
- .Value = Brr
- .Borders.LineStyle = 1
- .Font.Size = 11
- .HorizontalAlignment = xlCenter
- End With
- End With
-
- MsgBox "数据查询完毕!" & Chr(10) & _
- " - 用时" & Format(Timer - 时间, "#0.0000") & "秒! -"
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|