楼主
kevinchengcw |
Q: 如何用vba代码计算不同层级数据之和？
A: 实现代码如下：- Sub test()
- Dim Rng As Range, Str$, Str2$, Arr, N&, I&, T!, Total#, Dic As Object, Dic2 As Object
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- Set Dic2 = CreateObject("scripting.dictionary")
- Str = "一二三四五六七九八十,㈠㈡㈢㈣㈤㈥㈦㈧㈨㈩,⒈⒉⒊⒋⒌⒍⒎⒏⒐⒑,⑴⑵⑶⑷⑸⑹⑺⑻⑼⑽,①②③④⑤⑥⑦⑧⑨⑩" '引入层级列表字符串
- Arr = Split(Str, ",") '拆分层级列表字符串到数组
- For N = LBound(Arr) To UBound(Arr) '循环将不同层级各个字符内容写入字典中,key为字符,item为对应层级序号
- For I = 1 To Len(Arr(N))
- Dic(Mid(Arr(N), I, 1)) = N + 1
- Next I
- Next N
- With ActiveSheet '
- For Each Rng In .UsedRange.Cells '循环并清空填充黄色的单元格内容
- If Rng.Interior.ColorIndex = 6 Then Rng = ""
- Next Rng
- Arr = .[a1].Resize(.Cells(.Rows.Count, 1).End(3).Row, .Cells(1, .Columns.Count).End(1).Column).Value '提取表格区域数据到数组
- For I = LBound(Arr, 2) + 1 To UBound(Arr, 2) '循环表格内容各列(跳过标题列)
- Select Case I '判断列号
- Case 5, 7, 8, 10, 11, 12 '如果是指定列,则
- Str = "" '初始化层级序列字符串为空
- For N = LBound(Arr) + 2 To UBound(Arr) '循环当前列各行(跳过标题行及总计行)
- Str = Left(Left(Str, Dic(Trim(Arr(N, LBound(Arr, 2)))) - 1) & Space(9), Dic(Trim(Arr(N, LBound(Arr, 2)))) - 1) & Trim(Arr(N, LBound(Arr, 2))) '根据当前读取到的标识号提取出层级上层的字符串,不足的用空格补充(用于处理越级的情况)
- For T = 1 To Len(Str) '循环字符串各长度
- Str2 = Left(Str, T) '提取对应长度的字符串左侧内容
- If Dic2.exists(Str2) Then '字符串对应的内容进行合计
- Dic2(Str2) = Dic2(Str2) + Val(Arr(N, I))
- Else
- Dic2(Str2) = Val(Arr(N, I))
- End If
- Next T
- Next N
- Str = "" '清空字符串变量,进行下一次统计
- Total = 0 '总计初始化为0
- For N = LBound(Arr) + 2 To UBound(Arr) '二次循环数据区域
- Str = Left(Left(Str, Dic(Trim(Arr(N, LBound(Arr, 2)))) - 1) & Space(9), Dic(Trim(Arr(N, LBound(Arr, 2)))) - 1) & Trim(Arr(N, LBound(Arr, 2)))
- If Arr(N, I) = "" Then Arr(N, I) = Dic2(Str) '提取对就的数据到数组中
- If Len(Str) = 1 Then Total = Total + Dic2(Str) '如果是第一级,则将结果加和到汇总数据中
- Next N
- Arr(LBound(Arr) + 1, I) = Total '写入汇总的数据值
- Dic2.RemoveAll '清空字典2项目,以便进行下次处理
- Case Else
-
- End Select
- Next I
- .[a1].Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr '向数据区写入结果
- End With
- Set Dic = Nothing '清空字典项目
- Set Dic2 = Nothing
- End Sub
详见附件及素材源帖。
 分级汇总.rar
|