求助大佬，分类汇总还有按日期小计问题，万分感谢！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("源数据表")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:h" & r)
   
9.   End With
   
10.   s = 0
    
11.   For i = 1 To UBound(arr)
    
12.     If Not d.exists(arr(i, 1)) Then
    
13.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
14.     End If
    
15.     If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
16.       s = s + 1
    
17.       ReDim brr(1 To 9)
    
18.       brr(1) = arr(i, 1)
    
19.       brr(2) = arr(i, 2)
    
20.     Else
    
21.       brr = d(arr(i, 1))(arr(i, 2))
    
22.     End If
    
23.     Select Case arr(i, 3)
    
24.       Case "床垫"
    
25.         n = 3
    
26.       Case "家具"
    
27.         n = 4
    
28.       Case "其他材料"
    
29.         n = 5
    
30.       Case "软床沙发"
    
31.         n = 6
    
32.       Case Else
    
33.         n = 7
    
34.     End Select
    
35.     brr(n) = brr(n) + arr(i, 8)
    
36.     brr(8) = brr(8) + arr(i, 8)
    
37.     d(arr(i, 1))(arr(i, 2)) = brr
    
38.   Next
    
39.   ReDim crr(1 To s + d.Count, 1 To 9)
    
40.   m = 0
    
41.   For Each aa In d.keys
    
42.     ReDim drr(1 To 9)
    
43.     drr(1) = aa
    
44.     drr(2) = "小计"
    
45.     For Each bb In d(aa).keys
    
46.       brr = d(aa)(bb)
    
47.       For j = 3 To 8
    
48.         drr(j) = drr(j) + brr(j)
    
49.       Next
    
50.       m = m + 1
    
51.       For j = 1 To UBound(brr)
    
52.         crr(m, j) = brr(j)
    
53.       Next
    
54.     Next
    
55.     m = m + 1
    
56.     For j = 1 To UBound(drr)
    
57.       crr(m, j) = drr(j)
    
58.     Next
    
59.   Next
    
60.   With Worksheets("日报表")
    
61.     .Range("a4:i" & .Rows.Count).ClearContents
    
62.     With .Range("a4").Resize(UBound(crr), UBound(crr, 2))
    
63.       .Value = crr
    
64.       .Borders.LineStyle = xlContinuous
    
65.     End With
    
66.     For i = 1 To UBound(crr)
    
67.       If crr(i, 2) = "小计" Then
    
68.         .Cells(i + 3, 1).Resize(1, 9).Interior.ColorIndex = 6
    
69.       End If
    
70.     Next
    
71.   End With
    
72. End Sub
    

复制代码

chxw68

详见附件。

longming3

我的思路是先建立索引，在进行汇总计算，然后在判断前后日期不等就增加一行进行小计，最后加框框加颜色。
代码有点长，不过能达到效果。觉得还行，记得送花花。

xiangbaoan

1. Sub test1()
   
2.   Dim Cnn As Object, Rst As Object, SQL As String, ar(3) As String, i As Integer
   
3.   Set Cnn = CreateObject("ADODB.Connection")
   
4.   Set Rst = CreateObject("ADODB.Recordset")
   
5.   Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
   
6.   ar(0) = "SELECT 日期,[地区/联系人/电话],分类,金额 FROM [源数据表$A1:H]"
   
7.   ar(1) = "SELECT 日期,'小计' AS [地区/联系人/电话],分类,SUM(金额) AS 金额 FROM [源数据表$A1:H] GROUP BY 日期,分类"
   
8.   ar(2) = "SELECT 日期,'小计' AS [地区/联系人/电话],'合计' AS 分类,SUM(金额) AS 金额 FROM [源数据表$A1:H] GROUP BY 日期,分类"
   
9.   ar(3) = "SELECT 日期,[地区/联系人/电话],'合计' AS 分类,金额 FROM [源数据表$A1:H]"
   
10.   SQL = "TRANSFORM SUM(金额) SELECT 日期,[地区/联系人/电话] FROM (" & Join(ar, " UNION ALL ") & ") " & _
    
11.         "GROUP BY 日期,[地区/联系人/电话] PIVOT 分类 IN ('床垫','家具','其他材料','软床沙发','茶几电视柜餐桌椅子','合计','备注')"
    
12.   Rst.Open SQL, Cnn, 1, 3
    
13.   With Worksheets("日报表").Range("A3")
    
14.     .Resize(5678, 9).ClearContents
    
15.     For i = 0 To Rst.Fields.Count - 1
    
16.       .Offset(0, i) = Rst.Fields(i).Name
    
17.     Next
    
18.     .Offset(1).CopyFromRecordset Rst
    
19.   End With
    
20.   Rst.Close
    
21.   Set Rst = Nothing
    
22.   Cnn.Close
    
23.   Set Cnn = Nothing
    
24.   Beep
    
25. End Sub

复制代码

xiangbaoan

纯练习SQL.zip (23.8 KB, 下载次数: 13)

2022-1-6 12:06 上传

点击文件名下载附件

dj530116

small_small 发表于 2022-1-6 09:12
试试这个可以不

可以，但是有点bug

dj530116

chxw68 发表于 2022-1-6 10:48
详见附件。

功能实现，完全没问题！大神威武，感谢

dj530116

xiangbaoan 发表于 2022-1-6 12:06

功能实现，但是用SQL的话ofice和wps混着用，不太友好，谢谢帮助，努力学习中

dj530116

longming3 发表于 2022-1-6 11:03
我的思路是先建立索引，在进行汇总计算，然后在判断前后日期不等就增加一行进行小计，最后加框框加颜色。
...

代码没问题，学习中，小白问题多，感谢支持

3190496160

Sub 汇总()
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("源数据表")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:h" & rs)
End With
With Sheets("日报表")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r > 3 Then
        .Range("a4:i" & r).Borders.LineStyle = 0
        .Range("a4:i" & r) = Empty
    End If
    br = .Range("a3:i" & rs)
    For j = 3 To UBound(br, 2) - 2
        If Trim(br(1, j)) <> "" Then
            d(Trim(br(1, j))) = j
        End If
    Next j
    k = 1
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" Then
            zf = ar(i, 1) & "|" & Trim(ar(i, 2))
            t = d(zf)
            If t = "" Then
                k = k + 1
                d(zf) = k
                t = k
                br(k, 1) = ar(i, 1)
                br(k, 2) = ar(i, 2)
                dc(br(k, 1)) = ""
            End If
            lh = d(Trim(ar(i, 3)))
            If lh <> "" Then
                 br(t, lh) = br(t, lh) + ar(i, 8)
            End If
        End If
    Next i
    For i = 2 To k
        For j = 3 To UBound(br, 2) - 2
            If br(i, j) = "" Then br(i, j) = 0
            br(i, 8) = br(i, 8) + br(i, j)
        Next j
    Next i
    For Each kc In dc.keys
        n = 0
        ReDim arr(1 To k, 1 To UBound(br, 2))
        For i = 2 To k
            If br(i, 1) = kc Then
                n = n + 1
                For j = 1 To UBound(br, 2)
                    arr(n, j) = br(i, j)
                Next j
            End If
        Next i
        ws = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        .Cells(ws, 1).Resize(n, UBound(arr, 2)) = arr
        .Cells(ws + n, 2) = "小计"
        For j = 3 To UBound(br, 2) - 1
            .Cells(ws + n, j) = Application.Sum(Application.Index(arr, 0, j))
        Next j
       .Cells(ws, 1).Resize(n + 1, UBound(arr, 2)).Borders.LineStyle = 1
    Next kc
End With
MsgBox "ok!"

End Sub