求助按给出表的格式汇总的代码

lzqmsy

求助按给出表的格式汇总的代码,谢谢各位老师,附件在下楼

lzqmsy

求助代码.rar (51.77 KB, 下载次数: 8)

2014-7-15 23:03 上传

点击文件名下载附件

,再次谢谢!!!

lzqmsy

我在线等呢,哪位老师牺牲点休息时间出手相助,万分感谢!!!

lzqmsy

已经有22人查看了,有老师在给做吗?太晚了,各位老师都休息吧,明天再做,再次谢谢了!!!

zax010

Sub zz()
    Dim d, arr, brr
    Set d = CreateObject("Scripting.Dictionary")
    arr = Sheet1.[a1].CurrentRegion
    Sheet4.Range("A5").Resize(30, 27) = ""
    brr = Sheet4.Range("A3").Resize(30, 27)
    m = 3
    For i = 2 To UBound(arr)
        s = arr(i, 2)
        If d(s) = "" Then
            d(s) = m
            brr(m, 1) = arr(i, 2)
            For j = 4 To UBound(brr, 2)
                If brr(1, j) <> "" And Month(arr(i, 1)) = brr(1, j) Then
                    brr(m, j) = arr(i, 3)
                    brr(m, j + 1) = arr(i, 5)
                    brr(m, 2) = arr(i, 3)
                    brr(m, 3) = arr(i, 5)
                End If
            Next
            m = m + 1
        Else
            For j = 4 To UBound(brr, 2)
                If brr(1, j) <> "" And Month(arr(i, 1)) = brr(1, j) Then
                    brr(d(s), j) = brr(d(s), j) + arr(i, 3)
                    brr(d(s), j + 1) = brr(d(s), j + 1) + arr(i, 5)
                    brr(d(s), 2) = brr(d(s), 2) + arr(i, 3)
                    brr(d(s), 3) = brr(d(s), 3) + arr(i, 5)
                End If
            Next
        End If
    Next
    With Sheet4
        .Range("A3").Resize(m, 27) = brr
        .Range("A" & m + 2) = "合计"
        .Range("B" & m + 2) = "=SUM(B5:B" & m + 1 & ")"
        .Range("B" & m + 2).AutoFill Destination:=.Range("B" & m + 2 & ":" & "AA" & m + 2), Type:=xlFillDefault
    End With
End Sub

zax010

>>>>>>>>>>

求助代码.rar (52.69 KB, 下载次数: 50)

2014-7-16 00:27 上传

点击文件名下载附件

lzqmsy

zax010 发表于 2014-7-16 00:27
>>>>>>>>>>

谢谢,很好用的,慢慢学习,再次谢谢!!!

lzqmsy

zax010 发表于 2014-7-16 00:27
>>>>>>>>>>

老师你好,你写的代码我今天学习很长时间,颇有收获,谢谢您,还要请教一下,用sql能否实现,等待您的回复

chxw68

用ADO+SQL查询的数据，最后用数组进行了汇总处理。

1. Sub test()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   mybook = ThisWorkbook.FullName
   
7.   With cnn
   
8.     If Application.Version = "11.0" Then
   
9.       .Provider = "microsoft.jet.oledb.4.0"
   
10.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
11.     Else
    
12.       .Provider = "microsoft.ACE.oledb.12.0"
    
13.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;"";data source=" & mybook
    
14.     End If
    
15.     .Open
    
16.   End With
    
17.   sql1 = "transform sum(数量) as 数量  select 省份 from [台帐$a1:e] group by 省份 pivot month(月日)"
    
18.   sql2 = "transform sum(金额) as 销售金额  select 省份 from [台帐$a1:e] group by 省份 pivot month(月日)"
    
19.   arr = cnn.Execute(sql1).GetRows()
    
20.   brr = cnn.Execute(sql2).GetRows()
    
21.   ReDim crr(1 To UBound(arr, 2) + 1, 1 To 27)
    
22.   For j = 0 To UBound(arr, 2)
    
23.     crr(j + 1, 1) = arr(0, j)
    
24.     For i = 1 To UBound(arr)
    
25.       crr(j + 1, i * 2 + 2) = arr(i, j)
    
26.       crr(j + 1, 2) = crr(j + 1, 2) + arr(i, j)
    
27.     Next
    
28.   Next
    
29.   For j = 0 To UBound(brr, 2)
    
30.     For i = 1 To UBound(brr)
    
31.       crr(j + 1, i * 2 + 3) = brr(i, j)
    
32.       crr(j + 1, 3) = crr(j + 1, 3) + brr(i, j)
    
33.     Next
    
34.   Next
    
35.   With Worksheets("我要的效果")
    
36.     .UsedRange.Offset(4, 0).ClearContents
    
37.     .Range("a5").Resize(UBound(crr), UBound(crr, 2)) = crr
    
38.     R = .Cells(.Rows.Count, 1).End(xlUp).Row
    
39.     .Cells(R + 1, 1) = "合计"
    
40.     .Cells(R + 1, 2).Resize(1, 26).FormulaR1C1 = "=SUM(R[" & 4 - R & "]C:R[-1]C)"
    
41.   End With
    
42. End Sub
    

复制代码

chxw68

参见附件。