[已解决]求用VBA实现多条件分类汇总，请帮帮忙，谢谢！

wzw9999

把“每日数据”表中的“银行代码”、“预算单位代码”、“功能类科目代码”三者相同的支出发生额进行分类汇总，汇总数放到“分类汇总表”中，在“分类汇总表”表中放一个“分类汇总”按钮，点一下按钮就将“每日数据”表中的数据分类汇总到“分类汇总表”中。“每日数据”表中的记录数是不固定的。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-7-24 14:40

插入一个模块，粘入代码，在工作表中插入一个按钮，按钮的宏指向TEST

1. Sub test()
   
2.     Dim strSql As String
   
3.     strSql = "select 银行代码,预算单位代码,功能类科目代码,sum(支出发生额) from [每日数据$a:d] group by 银行代码,预算单位代码,功能类科目代码"
   
4.     Call ADOQuery(ThisWorkbook.FullName, strSql)
   
5.     MsgBox "汇总完成"
   
6. End Sub
   
7. 
   
8. Sub ADOQuery(strFullname As String, Optional strSql As String, Optional blnHasHeader As Boolean = True)
   
9. '需要定义的常量
   
10.     Const adUseClient = 3
    
11.     Const adModeShareDenyWrite = 8
    
12.     Const adModeReadWrite = 3
    
13.     Const adModeRead = 1
    
14. 
    
15.     Dim AdoConn As Object, AdoRst As Object
    
16.     Dim StrConn$
    
17. 
    
18.     Set AdoConn = CreateObject("ADODB.Connection")
    
19. 
    
20.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
21.               "Data Source='" & strFullname & "';Extended Properties='Excel 8.0;HDR=" & blnHasHeader & ";imex=1';"
    
22. 
    
23.     Debug.Print StrConn
    
24.    
    
25.     On Error GoTo ErrorHandler
    
26. 
    
27.     With AdoConn
    
28.         .CommandTimeout = 15
    
29.         .ConnectionTimeout = 15
    
30.         .CursorLocation = adUseClient
    
31.         .Mode = adModeRead    'Write    'adModeShareDenyWrite
    
32.         .ConnectionString = StrConn
    
33.         .Open
    
34.     End With
    
35. 
    
36.     Debug.Print strSql
    
37.     Set AdoRst = AdoConn.Execute(strSql)
    
38.     Worksheets("分类汇总").Range("a2").CopyFromRecordset AdoRst
    
39. 
    
40.     AdoConn.Close
    
41.     Exit Sub
    
42. 
    
43. ErrorHandler:
    
44.     MsgBox Err.Number & vbCrLf & _
    
45.            Err.Description
    
46.     Set AdoRst = Nothing
    
47.     Set AdoConn = Nothing
    
48. End Sub

复制代码

跳转到最佳答案楼层

w2001pf

如何汇总？

wzw9999

把“银行代码”、“预算单位代码”、“功能类科目代码”三个都相同的支出发生额进行汇总，汇总数据放到“分类汇总表”中。

hwc2ycy

用字典+数组，实现很容易。
另外，用SQL来实现应该也很简单。

hwc2ycy

SQL代码：

1. select 银行代码,预算单位代码,功能类科目代码,sum(支出发生额) from [每日数据$a:d] group by 银行代码,预算单位代码,功能类科目代码

复制代码

hwc2ycy

插入一个模块，粘入代码，在工作表中插入一个按钮，按钮的宏指向TEST

1. Sub test()
   
2.     Dim strSql As String
   
3.     strSql = "select 银行代码,预算单位代码,功能类科目代码,sum(支出发生额) from [每日数据$a:d] group by 银行代码,预算单位代码,功能类科目代码"
   
4.     Call ADOQuery(ThisWorkbook.FullName, strSql)
   
5.     MsgBox "汇总完成"
   
6. End Sub
   
7. 
   
8. Sub ADOQuery(strFullname As String, Optional strSql As String, Optional blnHasHeader As Boolean = True)
   
9. '需要定义的常量
   
10.     Const adUseClient = 3
    
11.     Const adModeShareDenyWrite = 8
    
12.     Const adModeReadWrite = 3
    
13.     Const adModeRead = 1
    
14. 
    
15.     Dim AdoConn As Object, AdoRst As Object
    
16.     Dim StrConn$
    
17. 
    
18.     Set AdoConn = CreateObject("ADODB.Connection")
    
19. 
    
20.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
21.               "Data Source='" & strFullname & "';Extended Properties='Excel 8.0;HDR=" & blnHasHeader & ";imex=1';"
    
22. 
    
23.     Debug.Print StrConn
    
24.    
    
25.     On Error GoTo ErrorHandler
    
26. 
    
27.     With AdoConn
    
28.         .CommandTimeout = 15
    
29.         .ConnectionTimeout = 15
    
30.         .CursorLocation = adUseClient
    
31.         .Mode = adModeRead    'Write    'adModeShareDenyWrite
    
32.         .ConnectionString = StrConn
    
33.         .Open
    
34.     End With
    
35. 
    
36.     Debug.Print strSql
    
37.     Set AdoRst = AdoConn.Execute(strSql)
    
38.     Worksheets("分类汇总").Range("a2").CopyFromRecordset AdoRst
    
39. 
    
40.     AdoConn.Close
    
41.     Exit Sub
    
42. 
    
43. ErrorHandler:
    
44.     MsgBox Err.Number & vbCrLf & _
    
45.            Err.Description
    
46.     Set AdoRst = Nothing
    
47.     Set AdoConn = Nothing
    
48. End Sub

复制代码

hwc2ycy

1. Sub MergeData()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : MergeData
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/7/24
   
6. ' Purpose   : 字典+数组，汇总
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9.     Dim arr, arrResult, lCur As Long, lCount As Long
   
10.     Dim key As String
    
11.     Dim i As Long, j As Long
    
12.     arr = Worksheets("每日数据").Range("a1").CurrentRegion.Value
    
13.     If Not IsArray(arr) Then
    
14.         MsgBox "A1单元格区域无有效数据"
    
15.         Exit Sub
    
16.     End If
    
17.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
    
18.     Dim objDic As Object
    
19.     Set objDic = CreateObject("scripting.dictionary")
    
20.     For i = LBound(arr) To UBound(arr)
    
21.         key = arr(i, 1) & "#" & arr(i, 2) & "#" & arr(i, 3)
    
22.         If objDic.exists(key) Then
    
23.             lCur = objDic(key)
    
24.         Else
    
25.             lCur = lCount + 1
    
26.             objDic(key) = lCur
    
27.             For j = LBound(arr, 2) To UBound(arr, 2) - 1
    
28.                 arrResult(lCur, j) = arr(i, j)
    
29.             Next
    
30.             arrResult(lCur, 1) = "'" & arr(i, 1)
    
31.             lCount = lCount + 1
    
32.         End If
    
33.         arrResult(lCur, 4) = arrResult(lCur, 4) + arr(i, 4)
    
34.     Next
    
35.     Stop
    
36.     If lCount Then
    
37.         Worksheets("分类汇总").Range("a1").Resize(lCount, UBound(arr, 2)).Value = arrResult
    
38.         MsgBox "汇总完成"
    
39.     End If
    
40. End Sub

复制代码

wzw9999

hwc2ycy 发表于 2013-7-24 14:40
插入一个模块，粘入代码，在工作表中插入一个按钮，按钮的宏指向TEST

按您的方法做了以后，点按钮出现3706错误

hwc2ycy

你用的是什么版本的OFFICE？

wzw9999

2010的，工作环境要2003的