一维转二维汇总统计

ykcbf1100

hyhsql 发表于 2024-11-19 16:00
ykcbf1100老师还需麻烦您给看看如何修改，当数据多时没有按月排序。

改一下吧，加个排序

ykcbf1100

改一下。。。

1. Sub ykcbf()   '//2024.11.22
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 100)
   
6.     On Error Resume Next
   
7.     M = 2: n = 3
   
8.     With Sheets("基础数据")
   
9.         r = .Cells(Rows.Count, 1).End(3).Row
   
10.         zrr = .[a1].Resize(r, 7)
    
11.         Set Rng = .[a2].Resize(r - 1, 7)
    
12.         With Rng
    
13.             .Parent.Sort.SortFields.Clear
    
14.             .Sort key1:=.Item(1), order1:=1, key2:=.Item(5), order2:=1, Header:=2
    
15.         End With
    
16.         arr = Rng.Value
    
17.         .[a1].Resize(r, 7) = zrr
    
18.     End With
    
19.     For j = 2 To 4
    
20.         brr(1, j - 1) = arr(1, j)
    
21.     Next
    
22.     For i = 2 To UBound(arr)
    
23.         s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    
24.         If Not d.exists(s) Then
    
25.             M = M + 1
    
26.             d(s) = M
    
27.             brr(M, 1) = arr(i, 2)
    
28.             brr(M, 2) = arr(i, 3)
    
29.             brr(M, 3) = arr(i, 4)
    
30.         End If
    
31.         r = d(arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4))
    
32.         s = arr(i, 1) & "|" & Format(arr(i, 5), "yyyy年m月")
    
33.         If Not d.exists(s) Then
    
34.             n = n + 1
    
35.             d(s) = n
    
36.             brr(1, n) = arr(i, 1)
    
37.             brr(2, n) = Format(arr(i, 5), "yyyy年m月")
    
38.         End If
    
39.         c = d(arr(i, 1) & "|" & Format(arr(i, 5), "yyyy年m月"))
    
40.         brr(r, c) = brr(r, c) + arr(i, 6)
    
41.     Next
    
42.     With Sheets("汇总")
    
43.         .UsedRange.Clear
    
44.         .[a1].Resize(2, n).Interior.Color = 49407
    
45.         With .[a1].Resize(M, n)
    
46.             .Value = brr
    
47.             .Borders.LineStyle = 1
    
48.             .HorizontalAlignment = xlCenter
    
49.             .VerticalAlignment = xlCenter
    
50.             With .Font
    
51.                 .Name = "微软雅黑"
    
52.                 .Size = 11
    
53.             End With
    
54.         End With
    
55.         For j = 1 To 3
    
56.             .Cells(1, j).Resize(2).Merge
    
57.         Next
    
58.         For j = n To 4 Step -1
    
59.             Set Rng = ActiveSheet.Cells(1, j)
    
60.             Set Rng1 = Rng.Offset(, -1)
    
61.             If Rng = Rng1 Then
    
62.                 Rng1.Resize(, 2).Merge     '//标题列向合并
    
63.             End If
    
64.         Next
    
65.         .[c2].Resize(M - 1).ShrinkToFit = True
    
66.     End With
    
67.     Application.ScreenUpdating = True
    
68.     MsgBox "OK！"
    
69. End Sub
    

复制代码

hyhsql

ykcbf1100 发表于 2024-11-22 14:12
改一下。。。

谢谢老师，我学习一下

hyhsql

望老师看看：汇总始终少一条，不知代码如何修改

ykcbf1100

hyhsql 发表于 2024-11-25 07:53
望老师看看：汇总始终少一条，不知代码如何修改

arr = .[a1].Resize(r, 7)，这句改一下就行。