按月数据汇总

szdcp

准提部林 发表于 2023-2-21 22:14
计数如何來的??
也做一個模版//

     非常感谢大神！程序很强大，超赞
     另外：考虑到工厂较少，月份较多，想把工厂名和月份位置调换不知道可以不

chxw68

1. Sub test3()
   
2.     Dim r%, i%
   
3.     Dim arr, brr, crr()
   
4.     Dim d As Object
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     With Worksheets("统计")
   
10.         .AutoFilterMode = False
    
11.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         arr = .Range("a2:w" & r)
    
13.     End With
    
14.     n = 2
    
15.     For i = 1 To UBound(arr)
    
16.         If Not d1.exists(arr(i, 1)) Then
    
17.             d1(arr(i, 1)) = n
    
18.             n = n + 6
    
19.         End If
    
20.     Next
    
21.     ls = 1 + d1.Count * 6
    
22.     For i = 1 To UBound(arr)
    
23.         rq = DateSerial(Year(arr(i, 6)), Month(arr(i, 6)), 1)
    
24.         If Not d.exists(rq) Then
    
25.             ReDim brr(1 To ls)
    
26.             brr(1) = rq
    
27.         Else
    
28.             brr = d(rq)
    
29.         End If
    
30.         n = d1(arr(i, 1))
    
31.         brr(n) = brr(n) + 1
    
32.         brr(n + 1) = brr(n + 1) + arr(i, 18)
    
33.         brr(n + 2) = brr(n + 2) + arr(i, 19)
    
34.         brr(n + 3) = brr(n + 3) + arr(i, 20)
    
35.         brr(n + 4) = brr(n + 4) + arr(i, 21)
    
36.         brr(n + 5) = brr(n + 5) + arr(i, 18) + arr(i, 19) + arr(i, 20) + arr(i, 21)
    
37.         d(rq) = brr
    
38.     Next
    
39.     ReDim crr(1 To d.Count, 1 To ls)
    
40.     m = 0
    
41.     For Each aa In d.keys
    
42.         brr = d(aa)
    
43.         m = m + 1
    
44.         For j = 1 To UBound(brr)
    
45.             crr(m, j) = brr(j)
    
46.         Next
    
47.     Next
    
48.     With Worksheets("样式")
    
49.         .Cells.Clear
    
50.         .Range("a3").Resize(UBound(crr), 1).NumberFormatLocal = "yyyy年m月"
    
51.         With .Range("a1")
    
52.             .Value = "工厂名"
    
53.             .Resize(2, 1).Merge
    
54.         End With
    
55.         n = 2
    
56.         For Each aa In d1.keys
    
57.             With .Cells(1, n)
    
58.                 .Value = aa
    
59.                 .Resize(1, 6).Merge
    
60.             End With
    
61.             .Cells(2, n).Resize(1, 6) = Array("计数", "外观", "组装", "包装", "机能", "合计")
    
62.             n = n + 6
    
63.         Next
    
64.         .Range("a3").Resize(UBound(crr), UBound(crr, 2)) = crr
    
65.         .Range("a3").Resize(UBound(crr), UBound(crr, 2)).Sort key1:=.Range("a3"), order1:=xlAscending, Header:=xlNo
    
66.         With .Range("a1").Resize(2 + UBound(crr), UBound(crr, 2))
    
67.             .Borders.LineStyle = xlContinuous
    
68.             With .Font
    
69.                 .Name = "微软雅黑"
    
70.                 .Size = 11
    
71.             End With
    
72.             .HorizontalAlignment = xlCenter
    
73.             .VerticalAlignment = xlCenter
    
74.         End With
    
75.     End With
    
76. End Sub
    
77. 
    

复制代码

chxw68

提供两种排列方式。

szdcp

chxw68 发表于 2023-2-22 10:46
提供两种排列方式。

程序超棒，感谢版主

chxw68

szdcp 发表于 2023-2-22 10:55
程序超棒，感谢版主

呵呵，我不是版主。

准提部林

szdcp 发表于 2023-2-22 09:56
非常感谢大神！程序很强大，超赞
     另外：考虑到工厂较少，月份较多，想把工厂名和月份位置调换 ...

做個想展示的表格格式看看~~

szdcp

准提部林 发表于 2023-2-22 12:10
做個想展示的表格格式看看~~

谢谢大神回复，想要的格式如下

准提部林

szdcp 发表于 2023-2-22 13:50
谢谢大神回复，想要的格式如下

橫向需要排序嗎?

szdcp

准提部林 发表于 2023-2-22 13:57
橫向需要排序嗎?

横向不需要排序

chxw68

szdcp 发表于 2023-2-22 13:50
谢谢大神回复，想要的格式如下

这种格式比前一种格式简单了，因为按日期排序方便了。