年月度统计

zllyyz

请教各位老师，vba如何按序逐“年月”按序统计数据（VBA日期函数好像只能日、月、季度、年度），烦请指教，谢谢。
需求如下图：

qline302

数据透视表的活，不需VBA

zllyyz

qline302 发表于 2024-2-13 18:07
数据透视表的活，不需VBA

透视表的活，vba应该更能做

fzxba

年月度统计.zip (24.76 KB, 下载次数: 39)

2024-2-13 18:41 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.2.14
   
2.     Application.ScreenUpdating = False
   
3.     Dim arr, brr, d
   
4.     Set ws = ThisWorkbook
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ws.Sheets("Sheet1")
   
7.     arr = ws.Sheets("Sheet2").UsedRange
   
8.     For i = 2 To UBound(arr)
   
9.         yf = Format(arr(i, 1), "yyyy-m")
   
10.         s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    
11.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
12.         d(s)(yf) = d(s)(yf) + arr(i, 5)
    
13.     Next
    
14.     On Error Resume Next
    
15.     ReDim brr(1 To 1000, 1 To 4)
    
16.     k = d.keys
    
17.     For i = 0 To UBound(k) Step 2
    
18.         m = m + 3
    
19.         For x = 0 To 1
    
20.             b = Split(k(i + x), "|")
    
21.             brr(m - 2 + x, 1) = b(0)
    
22.             brr(m - 2 + x, 2) = b(1)
    
23.             brr(m - 2 + x, 3) = b(2)
    
24.         Next
    
25.         brr(m, 2) = b(1) & " 抵消"
    
26.     Next
    
27.     With sh
    
28.         .UsedRange.Offset(5).Clear
    
29.         .Columns(1).NumberFormatLocal = "@"
    
30.         .[A6].Resize(m, 3) = brr
    
31.         arr = .UsedRange
    
32.         For i = 6 To UBound(arr)
    
33.             Sum = 0
    
34.             For j = 5 To UBound(arr, 2)
    
35.                 s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    
36.                 If d.exists(s) Then
    
37.                     arr(i, j) = d(s)(arr(5, j))
    
38.                     Sum = Sum + arr(i, j)
    
39.                 End If
    
40.             Next
    
41.             arr(i, 4) = Sum
    
42.             If InStr(arr(i, 2), "抵消") Then arr(i, 4) = arr(i - 2, 4) - arr(i - 1, 4)
    
43.         Next
    
44.         .Columns(1).NumberFormatLocal = "@"
    
45.         .UsedRange = arr
    
46.     End With
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码

zllyyz

fzxba 发表于 2024-2-13 18:41

看来得去练练SQL了？

zllyyz

ykcbf1100 发表于 2024-2-13 19:15
附件供参考。。。

还是 脑袋瓜子不太灵光,容错语句也没去试试

fzxba

zllyyz 发表于 2024-2-13 21:22
看来得去练练SQL了？

1. Sub test2() '数组+字典 再练习一下，也自动生成
   
2.   Dim ar(), br, cr, Dict As Object, strKey As String
   
3.   Dim i As Long, j As Long, k As Long
   
4.   Dim posRow As Long, posCol As Long, colSize As Long, rowSize As Long
   
5.   
   
6.   'Application.ScreenUpdating = False
   
7.   
   
8.   colSize = 4
   
9.   rowSize = 1
   
10.   cr = Split("应交,已交, 抵消", ",")
    
11.   br = Sheet2.Range("A1").CurrentRegion
    
12.   ReDim ar(1 To UBound(br), 1 To 40)
    
13.   
    
14.   Set Dict = CreateObject("Scripting.Dictionary")
    
15.   For j = 1 To colSize
    
16.     ar(rowSize, j) = Split("代码 单位名称 性质 总计")(j - 1)
    
17.     If j < 3 Then Dict.Add cr(j - 1), j - 1
    
18.   Next
    
19.   
    
20.   For i = 2 To UBound(br)
    
21.     strKey = Format(br(i, 1), "YYYY-MM")
    
22.     If Dict.Exists(strKey) Then
    
23.       posCol = Dict(strKey)
    
24.     Else
    
25.       colSize = colSize + 1
    
26.       posCol = colSize
    
27.       ar(1, colSize) = strKey
    
28.       Dict.Add strKey, colSize
    
29.     End If
    
30.    
    
31.     strKey = br(i, 2) & "|" & br(i, 3)
    
32.     If Dict.Exists(strKey) Then
    
33.       posRow = Dict(strKey)
    
34.     Else
    
35.       rowSize = rowSize + 3
    
36.       posRow = rowSize - 2
    
37.       Dict.Add strKey, posRow
    
38.       For k = 0 To 1
    
39.         For j = 1 To 2
    
40.           ar(posRow + k, j) = br(i, 1 + j)
    
41.         Next
    
42.         ar(posRow + k, j) = cr(k)
    
43.       Next
    
44.       ar(posRow + k, j - 1) = br(i, j) & cr(2)
    
45.     End If
    
46.     posRow = posRow + Dict(br(i, 4))
    
47.     ar(posRow, 4) = ar(posRow, 4) + Val(br(i, 5))
    
48.     ar(posRow, posCol) = ar(posRow, posCol) + Val(br(i, 5))
    
49.   Next
    
50.   
    
51.   For i = 4 To rowSize Step 3
    
52.     For j = 4 To colSize
    
53.       ar(i, j) = Val(ar(i - 2, j)) - Val(ar(i - 1, j))
    
54.   Next j, i
    
55.   BubbleSort ar, 1, rowSize, 5, colSize, 1
    
56.   
    
57.   With Sheet1.Range("A5")
    
58.     .CurrentRegion.Clear
    
59.     With .Resize(rowSize, colSize)
    
60.       .Borders.Weight = xlHairline
    
61.       .HorizontalAlignment = xlCenter
    
62.       .Columns(1).NumberFormatLocal = "@"
    
63.       .Rows(1).Font.Bold = True
    
64.       .Value = ar
    
65.     End With
    
66.   End With
    
67.   
    
68.   Set Dict = Nothing
    
69.   Application.ScreenUpdating = True
    
70.   Beep
    
71. End Sub
    
72. 
    
73. Function BubbleSort(ar, u As Long, d As Long, l As Long, r As Long, pos As Long)
    
74.   Dim j As Long, x As Long, y As Long, Flag As Boolean, Swap
    
75.   For j = l To r - 1
    
76.     Flag = True
    
77.     For x = l To r + l - 1 - j
    
78.       If CDate(ar(pos, x)) > CDate(ar(pos, x + 1)) Then
    
79.         Flag = False
    
80.         For y = u To d
    
81.           Swap = ar(y, x)
    
82.           ar(y, x) = ar(y, x + 1)
    
83.           ar(y, x + 1) = Swap
    
84.         Next
    
85.       End If
    
86.     Next
    
87.     If Flag = True Then Exit For
    
88.   Next
    
89. End Function

复制代码

fzxba

添加一种数组字典写法仅供测试.rar (32.68 KB, 下载次数: 34)

2024-2-14 09:04 上传

点击文件名下载附件