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

鄂龙蒙 · 发表于 2015-5-12 21:02

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

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

chxw68 · 发表于 2015-5-12 21:14

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim d1 As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("区域划分")
r = .Cells(.Rows.Count, 3).End(xlUp).Row
arr = .Range("b3:d" & r)
For i = 1 To UBound(arr)
If Len(arr(i, 1)) <> 0 Then
xm = arr(i, 1)
End If
d1(arr(i, 3)) = xm
Next
End With
With Worksheets("数据")
r = .Cells(.Rows.Count, 3).End(xlUp).Row
arr = .Range("a2:g" & r)
For i = 1 To UBound(arr)
If d1.exists(arr(i, 1)) Then
xm = d1(arr(i, 1))
End If
d(xm) = d(xm) + arr(i, 7)
Next
End With
With Worksheets("结果")
.Range("b4:c" & .Rows.Count).ClearContents
.Range("b4").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
r = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Cells(r, 2) = "合计"
.Cells(r, 3).FormulaR1C1 = "=SUM(R[" & 4 - r & "]C:R[-1]C)"
End With
End Sub

复制代码

chxw68 · 发表于 2015-5-12 21:15

详见附件。

yjh_27 · 发表于 2015-5-12 22:43

参见附件。

鄂龙蒙 · 发表于 2015-5-13 08:13

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:46

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

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

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

hlly888 · 发表于 2015-5-13 09:10

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 · 发表于 2015-5-13 09:11

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

XUYUJING2007 · 发表于 2015-5-13 09:16

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

鄂龙蒙 · 发表于 2015-5-13 09:32

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

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

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分

评分