ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > E问E答 > Excel VBA > 如何用vba代码依群组统计不同报表中的内容并生成汇总表及汇总工作簿?

如何用vba代码依群组统计不同报表中的内容并生成汇总表及汇总工作簿?

作者：绿色风 分类： 时间：2022-08-17 浏览：96
楼主
kevinchengcw		 Q: 如何用vba代码依群组统计不同报表中的内容并生成汇总表及汇总工作簿?
A: 代码如下：
  1. Sub test()
  2. Dim Dic As Object, Dic2 As Object, Wb As Workbook, Ws As Worksheet, NewWs As Worksheet, Rng1 As Range, Rng2 As Range, Rng3 As Range, RT As Range, RV As Range, RH As Range, FN$, Str$, N&, Arr(), I&
  3. On Error Resume Next '加上防错语句
  4. Application.ScreenUpdating = False '关闭屏幕刷新，提高处理速度
  5. Set Dic = CreateObject("scripting.dictionary") '创建字典项目
  6. Set Dic2 = CreateObject("scripting.dictionary")
  7. For Each Ws In Worksheets '将现有表名添加到字典2中，用于复制前判断是否已存在该表名
  8.     Dic2.Add Ws.Name, ""
  9. Next Ws
  10. FN = Dir(ThisWorkbook.Path & "\*.xls") '枚举当前目录下的excel文档
  11. Do While FN <> ""
  12.     If FN <> ThisWorkbook.Name Then '如果当前枚举到的文件名不是当前工作簿的文件名，则进行下述操作
  13.         Set Wb = GetObject(ThisWorkbook.Path & "\" & FN) '后台打开该工作簿，并赋值给工作簿变量
  14.         With Wb
  15.             For Each Ws In .Worksheets '循环该工作簿中各表
  16.                 With Ws
  17.                     If Not .Cells.Find("坐席") Is Nothing Then '如果存在关键字，则说明有有效数据
  18.                         If Not Dic2.exists(.Name) Then '判断是否已有该工作表名，没有的话，则在当前工作簿中新添加一个表，并复制源工作表中的数据区域到新表，并将新表的表名命名为源工作簿的无后扩展名的文件名
  19.                             Set NewWs = ThisWorkbook.Worksheets.Add
  20.                             NewWs.Name = Mid(Wb.Name, 1, InStrRev(Wb.Name, ".") - 1)
  21.                             .UsedRange.Copy NewWs.Range(.UsedRange.Address)
  22.                         End If
  23.                         Set Rng1 = .Cells.Find("坐席") '取得关键字所在的单元格的位置
  24.                         For Each RV In .Range(Rng1.Offset(1), .Cells(.Rows.Count, Rng1.Column).End(3).Offset(-2)) '循环姓名数据区
  25.                             If RV.Offset(, -1) <> "" Then N = RV.Offset(, -1).Value '提取组别号
  26.                             If RV <> "" And Not RV.Value Like "*合计*" Then '如果不是合计栏，则开始数据添加
  27.                                 Set Rng2 = .Cells.Find("死档") '取得标题行最后单元格位置
  28.                                 For Each RH In .Range(.Cells(Rng2.Row, Rng1.Offset(, 1).Column), Rng2.Offset(, -1)) '循环标题行各单元格
  29.                                     If Not RH.Value Like "*率*" And Not RH.Value Like "*计*" Then '如果当前标题行单元格不是公式列,则添加数据
  30.                                         Str = N & vbTab & RV.Value & vbTab & RH.Value '先配制字典的key(组别+姓名+标题行内容)
  31.                                         If Dic.exists(Str) Then '如果已有这样的key存在,则进行合计
  32.                                             Dic(Str) = Dic(Str) + .Cells(RV.Row, RH.Column).Value
  33.                                         Else '没有则进行添加
  34.                                             Dic.Add Str, .Cells(RV.Row, RH.Column).Value
  35.                                         End If
  36.                                     End If
  37.                                 Next RH
  38.                             End If
  39.                         Next RV
  40.                     End If
  41.                 End With
  42.             Next Ws
  43.         End With
  44.         Wb.Close False '关闭工作簿
  45.     End If
  46.     FN = Dir '循环到下一文件
  47. Loop
  48. Dic2.RemoveAll '清空字典2,用于下一步存放组别数据
  49. With Worksheets("汇总") '设置一下汇总表的位置并激活
  50.     .Move before:=Worksheets(1)
  51.     .Activate
  52. End With
  53. Rows("3:" & Rows.Count).Clear '清空旧的数据区内容
  54. Set Rng1 = Cells.Find("坐席") '取得标题行首尾位置
  55. Set Rng2 = Cells.Find("死档")
  56. Set RV = Rng1.Offset(1) '设置数据起始单元格位置
  57. Application.Calculation = xlCalculationManual '设置工作表重算为手动(因为会写入大量公式)
  58. Do While Dic.Count <> 0 '先判断字典中有没有数据,防止出错
  59.     Arr = Dic.keys '提取字典keys到数组中
  60.     I = Split(Arr(0), vbTab)(0) '取得第一个元素的组别并赋值给变量
  61.     Set Rng3 = RV '设置单元格变量为当前单元格(因该变量在后期合并组别单元格时作为合并区域起始单元格位置使用)
  62.     RV.Offset(, -1) = I '设置组别单元格的值为当前取得的值
  63.     For N = LBound(Arr) To UBound(Arr) '循环提取字典各key值
  64.         If Split(Arr(N), vbTab)(0) = I And Not Dic2.exists(Split(Arr(N), vbTab)(1)) Then Dic2.Add Split(Arr(N), vbTab)(1), "" '如果组别相同且姓名未出现在字典2中则添加
  65.     Next N
  66.     RV.Resize(Dic2.Count, 1) = Application.Transpose(Dic2.keys) '将字典2的数据转置到姓名区
  67.     For Each RT In RV.Resize(Dic2.Count, 1) '循环提取姓名区内容
  68.         For Each RH In Range(Rng1.Offset(, 1), Rng2) '循环提取标题区内容
  69.             Str = I & vbTab & RT.Value & vbTab & RH.Value '组合key用于判断
  70.             If Dic.exists(Str) Then '如果存在该key及对对应单元格赋值,并清除相应字典项
  71.                 Cells(RT.Row, RH.Column) = Dic(Str)
  72.                 Dic.Remove Str
  73.             End If
  74.         Next RH
  75.     Next RT
  76.     Set RV = RV.Offset(Dic2.Count) '姓名区单元格下移姓名区下一行位置
  77.     Dic2.RemoveAll '清空字典2用于下一次处理
  78.     With RV '写入合计行的内容,格式及公式
  79.         .Value = "合计"
  80.         .Interior.Color = vbYellow
  81.     End With
  82.     With Range(RV.Offset(, 1), Cells(RV.Row, Rng2.Column))
  83.         .FormulaR1C1 = "=sum(R[" & Rng3.Row - RV.Row & "]C:R[-1]C)"
  84.         .Interior.Color = vbYellow
  85.     End With
  86.     Set RV = RV.Offset(1)
  87. Loop
  88. With RV '全部执行完成后写入总计行数据
  89.     .Value = "总计"
  90.     .Interior.Color = vbRed
  91. End With
  92. With Range(RV.Offset(, 1), Cells(RV.Row, Rng2.Column))
  93.     .FormulaR1C1 = "=sum(R[" & Rng1.Row - RV.Row & "]C:R[-1]C)"
  94.     .Interior.Color = vbRed
  95. End With
  96. Set Rng3 = Rng1.Offset(1, -1)
  97. Application.DisplayAlerts = False '关闭警告提示,进行组别区单元格合并操作
  98. For Each RT In Range(Rng1.Offset(2, -1), RV.Offset(, -1))
  99.     If RT <> "" Or RT.Offset(1).Row > RV.Row Then
  100.         If Range(Rng3, RT.Offset(-1)).Cells.Count > 2 Then Range(Rng3, RT.Offset(-1)).Merge
  101.         Set Rng3 = RT
  102.     End If
  103. Next RT
  104. Application.DisplayAlerts = True '打开警告提示
  105. Set Rng3 = Cells(Rows.Count, Rng1.Column).End(3) '取得最后一行数据的位置,用于写入公式计算列
  106. Range(Rng1.Offset(, -1), Cells(Rng3.Row, Rng2.Column)).Borders.LineStyle = 1 '加上边框
  107. For Each RH In Range(Rng1.Offset(, 1), Rng2)
  108.     If RH.Value Like "*率*" Then
  109.         With Range(RH.Offset(1), Cells(Rng3.Row, RH.Column))
  110.             .Interior.Color = vbYellow
  111.             .NumberFormatLocal = "0.0%"
  112.             .FormulaR1C1 = "=IF(RC[-2]=0,0,RC[-1]/RC[-2])"
  113.         End With
  114.     ElseIf RH.Value Like "*计*" Then
  115.         With Range(RH.Offset(1), Cells(Rng3.Row, RH.Column))
  116.             .Interior.Color = vbYellow
  117.             .FormulaR1C1 = "=RC[-1]+RC[-2]"
  118.         End With
  119.     End If
  120. Next RH
  121. Application.Calculation = xlCalculationAutomatic '恢复计算模式为自动重算
  122. Set Dic = Nothing '清空字典项目
  123. Set Dic2 = Nothing
  124. Application.ScreenUpdating = True '打开屏幕刷新
  125. MsgBox "处理完成" '显示提示信息
  126. End Sub

补充内容 (2012-1-14 20:24):
附件补在三楼
2楼
yangkd2011		 没有附件，怎么也不能看到效果，谢谢！
3楼
kevinchengcw		 补上一楼附件
热一汇总修复总计.rar

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap