[發問] EXCEL VBA 日期區間如何統計

dou10801

請教各位前輩,日期區間如何統計,謝謝. 日期統計.rar (29.19 KB)

統計表
下載次數: 24

2020-10-21 10:00

ikboy

1. Sub zz()
   
2. Dim a, da As Date, dz As Date, dx As Date, n&, s$
   
3. Dim d As Object, m!
   
4. Set d = CreateObject("scripting.dictionary")
   
5. a = Sheets(1).[a1].CurrentRegion.Value
   
6. With Sheets(2)
   
7.     da = .[l2].Value: dz = .[l3].Value
   
8.     For i = 2 To UBound(a)
   
9.         dx = a(i, 7)
   
10.         If dx >= da And dx <= dz Then
    
11.             m = m + a(i, 4)
    
12.             n = n + 1
    
13.             s = a(i, 5) & "(" & a(i, 6)
    
14.             d(s) = d(s) + a(i, 4)
    
15.             For j = 1 To 8
    
16.                 a(n, j) = a(i, j + 1)
    
17.             Next
    
18.         End If
    
19.     Next
    
20.     .[a1].CurrentRegion.Offset(1).Clear
    
21.     .[a2].Resize(n, 8) = a
    
22.     .[a2].Resize(n, 8).Borders.Value = 1
    
23.     .Cells(n + 2, 2).Resize(1, 2) = Array("Total", m)
    
24.     For Each k In d.keys
    
25.         n = n + 1
    
26.         .Cells(n + 1, "d") = k & d(k) & "件)"
    
27.     Next
    
28. End With
    
29. End Sub

複製代碼

dou10801

感謝ikboy前輩回覆,執行中,停留在黃標上,請ikboy指導,謝謝.

dou10801

下載 (80.15 KB)
1111

2020-10-21 15:00

dou10801

ikboy抱歉,我自己操作錯誤,可以使用了,其他我自行修飾,感恩.

hcm19522

https://blog.xuite.net/hcm195222/blog/589428069

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
問題/條件/執行前:

下載 (160.86 KB)

2023-12-27 14:43

資料表:

下載 (272.04 KB)

2023-12-27 14:43

執行結果:

下載 (277.12 KB)

2023-12-27 14:44

Option Explicit
Sub TEST()
Dim Brr, Z, i&, j%, R&, 起始日 As Date, 結束日 As Date, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
[統計表!A1].CurrentRegion.Offset(1, 0).ClearContents
起始日 = [統計表!L2]: 結束日 = [統計表!L3]
Brr = Range([工作表1!I1], [工作表1!A65536].End(3))
For i = 2 To UBound(Brr)
   If Brr(i, 7) < 起始日 Or Brr(i, 7) > 結束日 Then GoTo i01 Else R = R + 1
   For j = 2 To 9: Brr(R, j - 1) = Brr(i, j): Next
   Z(Brr(i, 5) & "/" & Brr(i, 6)) = Z(Brr(i, 5) & "/" & Brr(i, 6)) + Val(Brr(i, 4))
i01: Next
If R = 0 Then Exit Sub
With [統計表!A2].Resize(R, 8)
   .Value = Brr
   .Cells(.Count + 2) = "Total"
   .Cells(.Count + 3) = "=SUM(" & .Columns(3).Address & ")"
   Set xR = .Cells(.Count + 4)
End With
For i = 0 To Z.Count - 1: Brr(i + 1, 1) = Z.keys()(i): Brr(i + 1, 2) = Z.items()(i): Next
xR.Resize(Z.Count, 2) = Brr
End Sub

hcm19522

(輸入編號12196) google網址:https://hcm19522.blogspot.com/

singo1232001

Sub test()
i = Split("Provider=Microsoft.,Jet.OLEDB.4,.0;Extended Properties=Excel ,8,.0;Data Source=", ",")
If Application.Version > 12 Then i(1) = "ACE.OLEDB.12": i(3) = 12
Set cn = CreateObject("adodb.connection"): cn.Open Join(i, "") & ThisWorkbook.FullName
Set s = Sheets("統計表"): s.[A:I].ClearContents
Set s1 = Sheets("工作表1"):
ar = Application.Index(s1.[a1:i1].Value, 1, 0)
s1.[a1:i1].ClearContents
q = "select F2,F3,F4,F5,F6,F7,F8,F9 from[工作表1$a1:J]where format(F7,""yyyy-MM-dd"")between'"
q = q & Format(s.[L2], "yyyy-MM-dd") & "'and'" & Format(s.[L3], "yyyy-MM-dd") & " 23:59:59'"
q = q & "order by F6,F7 asc"
s.[a2].CopyFromRecordset cn.Execute(q)
s.[a1:h1] = Split(Mid(Join(ar, ";;"), 7, 999), ";;")
s1.[a1:i1] = ar
End Sub