[已解决]谢谢hrpotter 老师。分类汇总程序报错

lhj323323

分类汇总已更新.rar (33.08 KB, 下载次数: 38)

2012-6-10 12:45 上传

点击文件名下载附件

老师:
上传的附件中有详细的说明,按三个标准进行分行分列的汇总,但是我写的程序运作出错,请看看,谢谢



另附一段代码,虽能导出数据,但与我想要的效果却有点不同,即不能把沪A和深A的分开
Sub 分类汇总2()
    Dim Myr1%, i%, r%
    Dim Dic1 As Object, dic2 As Object, arr1, arr2()
Application.DisplayAlerts = False
   
'arr1获得数据源的取数区域
    With Sheet2 '数据源
        Myr1 = .Range("a65536").End(xlUp).Row
        arr1 = .Range("a1:s" & Myr1)
'arr3获得结果表的横向标识
        Set Dic1 = CreateObject("scripting.dictionary")
        For i = 2 To UBound(arr1)
            Dic1(arr1(i, 18)) = "" '[数据源1]第18列,R列（交易类别）
        Next i
        arr3 = Dic1.Keys 'arr3取得所有交易类别名称
'arr4获得结果表的纵向标识
        Set dic2 = CreateObject("scripting.dictionary")
        For i = 2 To UBound(arr1)
            dic2(arr1(i, 1)) = "" '[数据源1]第1列,A列（客户号）
        Next i
        Arr4 = dic2.Keys 'arr4取得所有客户名称
'arr2获得结果表的数据提取区域
        ReDim arr2(1 To UBound(Arr4) + 2, 1 To 2 + Dic1.Count + 2)
'取数过程
    '生成结果表第一行的标识
        arr2(1, 1) = "客户号"
        arr2(1, 2) = "合计"
        For j = 0 To UBound(arr3)
            arr2(1, j + 2) = arr3(j)
        Next j
   
    '生成结果表第一列的标识
        For i = 0 To UBound(Arr4) '历遍arr4的客户号
            arr2(i + 2, 1) = Arr4(i)
            For j = 2 To UBound(arr1)
'<<1、设定结果表的3-n列
                If arr1(j, 1) = arr2(i + 2, 1) Then '如果客户号相同
                   '结果表横向标识，即品种有N个，只用一个参数n代替即可，也能成功，更简洁
                     For n = 0 To UBound(arr3)
                        If arr1(j, 18) = arr3(n) Then
                            arr2(i + 2, 2) = arr2(i + 2, 2) + arr1(j, 12) '"合计"
                            arr2(i + 2, 3 + n) = arr2(i + 2, 3 + n) + arr1(j, 12)
                        End If
                     Next n
               End If
            Next j
        Next i
    End With
'导入结果表到[分析]
   With Sheet7
        '.Cells.Clear
        .Range("a8").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2 '导入本期数据
        .Cells.Font.Size = 10
    End With
Application.DisplayAlerts = True
    Sheet7.Activate
End Sub

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-6-10 13:21

试下这个，分析表一二行是预先固定的

1. Sub 分类汇总()
   
2.     Dim ar, br, cr, dr
   
3.     Dim i As Integer, j As Integer
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Sheets("结果表")
   
7.         ar = .Range("a2:a" & .Range("a65536").End(xlUp).Row)
   
8.     End With
   
9.     With Sheets("分析")
   
10.         ReDim br(1 To 9)
    
11.         For i = 2 To 10
    
12.             If .Cells(1, i) = "" Then
    
13.                 br(i - 1) = .Cells(1, i - 1) & .Cells(2, i)
    
14.             Else
    
15.                 br(i - 1) = .Cells(1, i) & .Cells(2, i)
    
16.             End If
    
17.         Next
    
18.         cr = Sheets("数据源1").Range("a1").CurrentRegion
    
19.         For i = 2 To UBound(cr)
    
20.             If cr(i, 18) = "证券买入" Or cr(i, 18) = "证券卖出" Then
    
21.                 s = cr(i, 1) & cr(i, 18) & cr(i, 5)
    
22.             Else
    
23.                 s = cr(i, 1) & cr(i, 18)
    
24.             End If
    
25.             d(s) = d(s) + cr(i, 12)
    
26.         Next
    
27.         ReDim dr(1 To UBound(ar), 1 To UBound(br))
    
28.         For i = 1 To UBound(ar)
    
29.             For j = 1 To UBound(br)
    
30.                 dr(i, j) = d(ar(i, 1) & br(j))
    
31.             Next
    
32.         Next
    
33.         .Range("a3:j65536").Clear
    
34.         .Range("a3").Resize(UBound(ar), 1) = ar
    
35.         .Range("b3").Resize(UBound(dr), UBound(dr, 2)) = dr
    
36.     End With
    
37. End Sub

复制代码

跳转到最佳答案楼层

无聊的疯子

拿几行数据来举个例子吧,看不懂结果怎么放啊!!!

lhj323323

无聊的疯子 发表于 2012-6-10 12:33
拿几行数据来举个例子吧,看不懂结果怎么放啊!!!

老师:
我在一楼已更新了附件
新增了如下内容:
1\我想要的效果
2\另一个程序,虽然能提取出数据,但是不能把沪A和深A的数据分开,同时,也不能按[分析]的第1\2行固定的标识进行汇总

无聊的疯子

汇总的是变动资金?

lhj323323

无聊的疯子 发表于 2012-6-10 12:55
汇总的是变动资金?

汇总的是变动资金,

等语句调好后,我还将汇总变动的次数.

hrpotter

试下这个，分析表一二行是预先固定的

1. Sub 分类汇总()
   
2.     Dim ar, br, cr, dr
   
3.     Dim i As Integer, j As Integer
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Sheets("结果表")
   
7.         ar = .Range("a2:a" & .Range("a65536").End(xlUp).Row)
   
8.     End With
   
9.     With Sheets("分析")
   
10.         ReDim br(1 To 9)
    
11.         For i = 2 To 10
    
12.             If .Cells(1, i) = "" Then
    
13.                 br(i - 1) = .Cells(1, i - 1) & .Cells(2, i)
    
14.             Else
    
15.                 br(i - 1) = .Cells(1, i) & .Cells(2, i)
    
16.             End If
    
17.         Next
    
18.         cr = Sheets("数据源1").Range("a1").CurrentRegion
    
19.         For i = 2 To UBound(cr)
    
20.             If cr(i, 18) = "证券买入" Or cr(i, 18) = "证券卖出" Then
    
21.                 s = cr(i, 1) & cr(i, 18) & cr(i, 5)
    
22.             Else
    
23.                 s = cr(i, 1) & cr(i, 18)
    
24.             End If
    
25.             d(s) = d(s) + cr(i, 12)
    
26.         Next
    
27.         ReDim dr(1 To UBound(ar), 1 To UBound(br))
    
28.         For i = 1 To UBound(ar)
    
29.             For j = 1 To UBound(br)
    
30.                 dr(i, j) = d(ar(i, 1) & br(j))
    
31.             Next
    
32.         Next
    
33.         .Range("a3:j65536").Clear
    
34.         .Range("a3").Resize(UBound(ar), 1) = ar
    
35.         .Range("b3").Resize(UBound(dr), UBound(dr, 2)) = dr
    
36.     End With
    
37. End Sub

复制代码