楼主
liuguansky |
Q：如何多表按格式条件汇总各项目金额（要支持自由扩展项目）？
A:用如下代码可以实现：
- Sub justtest()
- Dim dic, arr, i&, sht As Worksheet, arrt(), a&, k&'定义变量
- Set dic = CreateObject("scripting.dictionary")'创建字典项目
- With Sheets("汇总")'获取汇总表
- a = .Range("a2").Value'赋值年份到变量
- For Each sht In Worksheets'在表中循环，不循环汇总表
- If sht.Name <> .Name Then'排除汇总表
- arr = sht.Range("a1").CurrentRegion.Value'把待汇总数据赋值数值，待内存处理
- For i = 2 To UBound(arr, 1)'数据间循环
- If arr(i, 1) = a Then'如果年份相同，则
- If dic.exists(arr(i, 5)) Then'如果项目已在字典中存在
- arrt(arr(i, 2), dic(arr(i, 5))) = arrt(arr(i, 2), dic(arr(i, 5))) + arr(i, 4)'则在当月行累加金额
- Else: k = k + 1: ReDim Preserve arrt(1 To 12, 1 To k): dic.Add arr(i, 5), k
- '如果不存在，则把项目加一个，同时扩展返回数组第二维；字典也对应创建出项目
- arrt(arr(i, 2), k) = arr(i, 4)'对初始金额进行赋值
- End If
- End If
- Next i
- End If
- Next
- .Range(.Cells(1, 3), .Cells(.Rows.Count, .Columns.Count)).Clear'清空待返回值区域，方便返回值，同时清除可能错误
- .Cells(1, 3).Resize(1, k) = dic.keys'返回项目清单
- .Cells(2, 3).Resize(12, k) = arrt' 返回数据汇总
- With .Cells(1, 3).Resize(13, k)'设置格式
- .Borders.LineStyle = xlContinuous
- .EntireColumn.AutoFit
- End With
- End With
- Set dic = Nothing'清空对象
- End Sub
|