按规定要求汇总代码怎么写

鄂龙蒙

请教:要将<数据>表按<区域划区>表中的已划分好的区域,用VBA汇总,谢谢!

按规定要求汇总.rar (23.25 KB, 下载次数: 26)

2015-5-12 21:02 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim d1 As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   With Worksheets("区域划分")
   
9.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
   
10.     arr = .Range("b3:d" & r)
    
11.     For i = 1 To UBound(arr)
    
12.       If Len(arr(i, 1)) <> 0 Then
    
13.         xm = arr(i, 1)
    
14.       End If
    
15.       d1(arr(i, 3)) = xm
    
16.     Next
    
17.   End With
    
18.   With Worksheets("数据")
    
19.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
20.     arr = .Range("a2:g" & r)
    
21.     For i = 1 To UBound(arr)
    
22.       If d1.exists(arr(i, 1)) Then
    
23.         xm = d1(arr(i, 1))
    
24.       End If
    
25.       d(xm) = d(xm) + arr(i, 7)
    
26.     Next
    
27.   End With
    
28.   With Worksheets("结果")
    
29.     .Range("b4:c" & .Rows.Count).ClearContents
    
30.     .Range("b4").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
31.     r = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
    
32.     .Cells(r, 2) = "合计"
    
33.     .Cells(r, 3).FormulaR1C1 = "=SUM(R[" & 4 - r & "]C:R[-1]C)"
    
34.   End With
    
35. End Sub
    

复制代码

chxw68

详见附件。

yjh_27

参见附件。

鄂龙蒙

yjh_27 发表于 2015-5-12 22:43
参见附件。

谢谢您提供"对二维数组按第L列(多列多次)排序"函数,这样套用函数后代码就简洁多了,
学习后还有些不懂,再请教:您给的代码中标红的
YjhSort(arr, "ua;3;1;2", "1", "c1,7;1;3", , , , , , brr)
能帮解释一下吗?谢谢!

yjh_27

鄂龙蒙 发表于 2015-5-13 08:13
谢谢您提供"对二维数组按第L列(多列多次)排序"函数,这样套用函数后代码就简洁多了,
学习后还有些不懂,再 ...

u 使用自定义数组，进行匹配-置换
a;升序
3;匹配brr  3列
1;置换brr  1列
2 匹配方式 包含
c1,统计  因只有一个分组，与C等价
7; 统计  arr 第7列
1; 按第1分组统计
3  合计

统计时：排序要求即分组要求
具体参见函数前部的说明

hlly888

    For i = 1 To UBound(brr)
        If Len(brr(i, 1)) > 0 Then a = brr(i, 1)
        dc(1)(brr(i, 3)) = a
    Next
    For i = 1 To UBound(arr)
        dc(2)(dc(1)(arr(i, 1))) = dc(2)(dc(1)(arr(i, 1))) + arr(i, 7)
        h = h + arr(i, 7)
    Next

hlly888

按区域汇总.zip (28.47 KB, 下载次数: 36)

2015-5-13 09:11 上传

点击文件名下载附件

XUYUJING2007

Sub aa()
    Dim arr, A As Integer, D, D1, S As String
    Set D = CreateObject("SCRIPTING.DICTIONARY")
    Set D1 = CreateObject("SCRIPTING.DICTIONARY")
    With Sheets("区域划分")
        For A = 3 To .Range("D65536").End(3).Row
            D(.Cells(A, 4).Value) = .Range("B" & A).MergeArea.Cells(1).Value
        Next
    End With
    With Sheets("数据")
        arr = .Range("A1").CurrentRegion
        For A = 2 To UBound(arr)
            S = D(arr(A, 1))
            D1(S) = D1(S) + arr(A, 7)
        Next
    End With
    With Sheets("结果")
        arr = .Range("B2").CurrentRegion
        For A = 3 To UBound(arr)
            arr(A, 2) = D1(arr(A, 1))
        Next
        .Range("B2").Resize(UBound(arr), UBound(arr, 2)) = arr
    End With
End Sub

鄂龙蒙

yjh_27 发表于 2015-5-13 08:46
u 使用自定义数组，进行匹配-置换
a;升序
3;匹配brr  3列

其它在您函数说明能对上号,就是"ua"对不上,也许我对参数不会套用,
第2个参数中只有:u;n;m;k;p    自定义匹配-置换处理
此式样共5个项目?
u-----"ua"对不上;
p-----没有?省略?