工作表按日期统计汇总

y1983y

各位大侠：上午好！


       原表工作表为系统导出清单，需要转换为模板工作表样式，目前采用SUMIFS公式统计，但是数据增多后反应缓慢，目前想采用VBA来实现，请各位大侠帮忙实现，谢谢大家！


       在各位大侠的帮助下，通过自己努力，在不改变模板工作表格式下实现了所要功能，再次谢谢大家！

limonet

你这个直接透视表吧，不用代码的，高效、环保。

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=b73ad3d6
字典的案例可以参考下

fzxba

1. Sub test1() '
   
2.   Dim Conn As Object, rs As Object, SQL As String, i As Integer
   
3.   
   
4.   Set Conn = CreateObject("ADODB.Connection")
   
5.   Set rs = CreateObject("ADODB.Recordset")
   
6.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
7.   
   
8.   Sheet2.Activate
   
9.   Cells.ClearContents
   
10.   
    
11.   SQL = "SELECT * FROM [原表$] WHERE LEN(编码)>0 UNION ALL "
    
12.   SQL = SQL & "SELECT 编码,SUM(数量) AS 数量,#" & DateAdd("M", -360, Date) & "# AS 日期 FROM [原表$] WHERE LEN(编码)>0 GROUP BY 编码"
    
13.   SQL = "TRANSFORM SUM(数量) SELECT 编码 FROM (" & SQL & ") GROUP BY 编码 PIVOT 日期"
    
14.   rs.Open SQL, Conn, 1, 3
    
15.   
    
16.   With Range("A1")
    
17.     For i = 0 To rs.Fields.Count - 1
    
18.       .Offset(0, i) = rs.Fields(i).Name
    
19.     Next
    
20.     .Offset(1).CopyFromRecordset rs
    
21.     .Offset(, 1) = "数量"
    
22.   End With
    
23.   
    
24.   rs.Close
    
25.   Set rs = Nothing
    
26.   Conn.Close
    
27.   Set Conn = Nothing
    
28. End Sub

复制代码

无关岁月

数据表转换.7z (131.75 KB, 下载次数: 17)

2024-3-25 12:30 上传

点击文件名下载附件

liulang0808

Sub 矩形1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set dt = CreateObject("scripting.dictionary")
    arr = Sheets("原表").UsedRange
    Application.ScreenUpdating = False
    Sheets("模板").UsedRange.ClearContents
    ReDim brr(1 To UBound(arr), 1 To UBound(arr))
    r = 1
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 1)) Then
            r = r + 1
            brr(r, 1) = arr(j, 1)
            d(arr(j, 1)) = ""
        End If
        d(arr(j, 1) & CDate(arr(j, 3))) = d(arr(j, 1) & CDate(arr(j, 3))) + arr(j, 2)
        dt(arr(j, 3) * 1) = CDate(arr(j, 3))
    Next j
    c = 2
    For j = 1 To dt.Count
        c = c + 1
        brr(1, c) = dt(WorksheetFunction.Small(dt.keys, j))
        For i = 2 To r
            brr(i, c) = d(brr(i, 1) & brr(1, c))
            brr(i, 2) = brr(i, c) + brr(i, 2)
        Next i
    Next j
    brr(1, 1) = "编码"
    brr(1, 2) = "数量"
    [a1].Resize(r, c) = brr
    Application.ScreenUpdating = True
End Sub

liulang0808

字典案例供参考。。。。。

y1983y

liulang0808 发表于 2024-3-25 12:33
字典案例供参考。。。。。

多谢版主出手，非常感谢！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.25
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Sheets("原表")
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .Range("a1").Resize(r, 3)
   
10.         For i = 2 To UBound(arr)
    
11.             s1 = CDate(arr(i, 3))
    
12.             d1(s1) = ""
    
13.             s = arr(i, 1)
    
14.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
15.             d(s)(s1) = d(s)(s1) + arr(i, 2)
    
16.         Next
    
17.     End With
    
18.     t = d1.keys: sort1 t, True
    
19.     With Worksheets("模板")
    
20.         .UsedRange.Offset(1, 2).Clear
    
21.         .[a2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    
22.         .[c1].Resize(1, d1.Count) = t
    
23.         Set Rng = .[a1].Resize(d.Count + 1, 2 + d1.Count)
    
24.         arr = Rng.Value
    
25.         .[a1].Resize(1, d1.Count + 2).Interior.Color = 49407
    
26.         .[a2].Resize(d.Count, 1).Interior.Color = 5296274
    
27.         For i = 2 To UBound(arr)
    
28.             Sum = 0
    
29.             For j = 3 To UBound(arr, 2)
    
30.                 s = arr(i, 1)
    
31.                 If d.exists(s) Then
    
32.                     arr(i, j) = d(s)(arr(1, j))
    
33.                     Sum = Sum + arr(i, j)
    
34.                 End If
    
35.             Next
    
36.             arr(i, 2) = Sum
    
37.         Next
    
38.         With Rng
    
39.             .Value = arr
    
40.             .Borders.LineStyle = 1
    
41.             .HorizontalAlignment = xlCenter
    
42.             .VerticalAlignment = xlCenter
    
43.             .Columns.AutoFit
    
44.             With .Font
    
45.                 .Name = "微软雅黑"
    
46.                 .Size = 11
    
47.             End With
    
48.         End With
    
49.     End With
    
50.     Set d = Nothing
    
51.     MsgBox "OK！"
    
52. End Sub

复制代码