新手求教学如何汇总多月份多数据进行统计陈哈卡

冠品烘焙

求助一下，这个多月份的多条数据如何进行统计并显示排列出来

蓝桥玄霜

统计的例子：

ynzsvt

1. Sub tyji()
   
2. '条件是表头如目前已知的样子，工作表名称与程序的对应。
   
3. Dim r&, Arr, Brr, Crr, Dic As Object, i&, j&, k&
   
4. ReDim Crr(0 To 999, 0 To 12)
   
5. Set Dic = CreateObject("Scripting.Dictionary")
   
6. With Worksheets("数据源")
   
7.   r = .Cells(Rows.Count, 1).End(xlUp).Row - 1
   
8.   Arr = .[a2].Resize(r, 2)
   
9.   Brr = .[h2].Resize(r, 1)
   
10. End With
    
11. For i = 1 To r
    
12.   If Dic.Exists(Arr(i, 1)) Then
    
13.    j = Dic(Arr(i, 1))
    
14.    k = Month(Arr(i, 2))
    
15.    Crr(j, k) = Crr(j, k) + Brr(i, 1)
    
16.   Else:
    
17.    j = Dic.Count: Dic(Arr(i, 1)) = j: Crr(j, 0) = Arr(i, 1)
    
18.    k = Month(Arr(i, 2))
    
19.    Crr(j, k) = Crr(j, k) + Brr(i, 1)
    
20.   End If
    
21. Next
    
22. 
    
23. With Worksheets("统计查看")
    
24. .[A3].Resize(Dic.Count, 13) = Crr
    
25. End With
    
26. Set Dic = Nothing
    
27. End Sub

复制代码

ynzsvt

针对的统计代码如图。

wang-way

冠品烘焙

ynzsvt 发表于 2024-8-11 12:11

Option Explicit

Sub tyji()
    Dim r&, Arr, Brr, Crr, Dic As Object, i&, j&, k&, sumAsNumeric As Double
    ReDim Crr(0 To 999, 0 To 12)
    Set Dic = CreateObject("Scripting.Dictionary")
   
    With Worksheets("数据源")
        r = .Cells(Rows.Count, 1).End(xlUp).Row - 1
        Arr = .Range("A2").Resize(r, 2)
        Brr = .Range("H2").Resize(r, 1)
    End With
   
    For i = 1 To r
        If Dic.Exists(Arr(i, 1)) Then
            j = Dic(Arr(i, 1))
            k = Month(Arr(i, 2))
            Crr(j, k) = Crr(j, k) + Brr(i, 1)
        Else
            j = Dic.Count: Dic(Arr(i, 1)) = j: Crr(j, 0) = Arr(i, 1)
            k = Month(Arr(i, 2))
            Crr(j, k) = Crr(j, k) + Brr(i, 1)
        End If
    Next i

    With Worksheets("统计查看")
        Dim strValue As String
        Dim unit As String
        unit = "元"  ' 单位
        
        For i = 0 To Dic.Count
            For j = 0 To 12
                If Crr(i, j) > 0 Then
                    strValue = Format(Crr(i, j), "0.00") & unit
                Else
                    strValue = ""  
                End If
                .Cells(i + 3, j + 1).Value = strValue
            Next j
            sumAsNumeric = WorksheetFunction.Sum(.Range(.Cells(i + 3, 2), .Cells(i + 3, 13)))
            .Cells(i + 3, 14).Value = Format(sumAsNumeric, "0.00") & unit
        Next i
    End With
   
    Set Dic = Nothing
End Sub
按照你这个我添加了最后一行的合计后，显示出来的结果没办法完全显示，只有0.00是什么情况

杨建营

1. Sub 统计()
   
2. Dim i&, j&
   
3. Dim arr, brr, d
   
4. Dim kh, yf
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Application.ScreenUpdating = False
   
7. With Sheets("数据源")
   
8.     arr = .[a1].CurrentRegion
   
9.     For i = 2 To UBound(arr)
   
10.         kh = arr(i, 1)
    
11.         yf = Month(CDate(arr(i, 2)))
    
12.         If Not d.exists(kh) Then Set d(kh) = CreateObject("Scripting.Dictionary")
    
13.         d(kh)(yf) = d(kh)(yf) + arr(i, 8)
    
14.     Next
    
15. End With
    
16. With Sheets("统计查看")
    
17.     ReDim brr(1 To 10000, 1 To 14)
    
18.     For Each kk In d.keys
    
19.         j = j + 1
    
20.         For Each kkk In d(kk).keys
    
21.             brr(j, 1) = kk
    
22.             brr(j, kkk + 1) = d(kk)(kkk)
    
23.             brr(j, 14) = brr(j, 14) + d(kk)(kkk)
    
24.         Next
    
25.     Next
    
26.     .Cells(2, 1).CurrentRegion.Offset(2).Resize(, 14).Clear
    
27.     .Cells(3, 1).Resize(j, 14) = brr
    
28. End With
    
29. Application.ScreenUpdating = True
    
30. End Sub

复制代码

参与一下。

ykcbf1100

字典排重汇总

ykcbf1100

字典排重汇总

1. Sub ykcbf()   '//2024.8.11  排重汇总
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 100)
   
6.     m = 0: n = 1
   
7.     On Error Resume Next
   
8.     With Sheets("数据源")
   
9.         r = .Cells(Rows.Count, 1).End(3).Row
   
10.         c = .UsedRange.Columns.Count
    
11.         arr = .[a1].Resize(r, c)
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         s = arr(i, 1)
    
15.         If Not d.exists(s) Then
    
16.             m = m + 1
    
17.             d(s) = m
    
18.             brr(m, 1) = s
    
19.         End If
    
20.         r = d(arr(i, 1))
    
21.         rq = CDate(arr(i, 2))
    
22.         s = DatePart("m", rq)
    
23.         If Not d.exists(s) Then
    
24.             n = n + 1
    
25.             d(s) = n
    
26.         End If
    
27.         c = d(DatePart("m", rq))
    
28.         brr(r, c) = brr(r, c) + arr(i, 8)
    
29.     Next
    
30.     With Sheets("统计查看")
    
31.         .[a3:n10000].Clear
    
32.         .[a2].Resize(1, 14).Interior.Color = 49407
    
33.         With .[a3].Resize(m, 14)
    
34.             .Value = brr
    
35.             .Borders.LineStyle = 1
    
36.             .HorizontalAlignment = xlCenter
    
37.             .VerticalAlignment = xlCenter
    
38.         End With
    
39.         For i = 3 To m + 2
    
40.             .Cells(i, 14) = Application.Sum(.Cells(i, 2).Resize(, 12))
    
41.         Next
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "OK！"
    
45. End Sub
    

复制代码

Qs18

Sub qs()
Dim arr, i, dic
arr = Sheet1.Range("a1").CurrentRegion.Value
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
On Error Resume Next
For i = 2 To UBound(arr)
    m = arr(i, 1): ym = VBA.Month(CDate(arr(i, 2)))
    s = m & "|" & ym
    If Not dic.exists(s) Then
        dic(s) = arr(i, 8)
    Else
        dic(s) = dic(s) + arr(i, 8)
    End If
dic2(m) = ""
Next
Sheet3.Range("a3").Resize(10000, 14).ClearContents
Sheet3.Range("a3").Resize(dic2.Count, 1) = Application.WorksheetFunction.Transpose(dic2.keys)
rw = Sheet3.Cells(Rows.Count, 1).End(3).Row
brr = Sheet3.Range("a3:m" & rw)
crr = Sheet3.Range("n3:n" & rw)
For Each k In dic.keys
    x = Split(k, "|")
    For i = 1 To UBound(brr)
       If brr(i, 1) = x(0) Then
            brr(i, Val(x(1)) + 1) = dic(k)
       End If
    Next
Next
For i = 1 To UBound(brr)
    crr(i, 1) = Application.Sum(Application.Index(brr, i, 0))
Next
Sheet3.Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
Sheet3.Range("n3").Resize(UBound(crr), 1) = crr
Set dic = Nothing: Set dic2 = Nothing
End Sub