ExcelTip.Net留存知识帖 ---【注:附件之前被网盘供应商清空后,现已修复-现已修复-现已修复为本地下载!】
现在位置:首页 > E问E答 > Excel VBA > 如何利用vba自定义不定标题列多表合并函数?

如何利用vba自定义不定标题列多表合并函数?

作者:绿色风 分类: 时间:2022-08-17 浏览:144
楼主
kevinchengcw
Q: 如何利用vba自定义不定标题列多表合并函数?
A: 实现代码如下:
  1. '***************************************************************************************************************
  2. 'MergeData 多工作表汇总函数,对多个格式相同的工作表进行汇总
  3. '要求: 标准二维表格,工作表的标题行位置一致,要汇总的数据起始列位置一致,关键字列的位置一致
  4. '返回值: 汇总后结果的数组或出错时返回文本"Error!"
  5. '参数说明:
  6. 'TotalWorkbooFullName: 文本型,要汇总的工作簿全路径名(可以是打开或未打开的工作簿)
  7. 'TotalSheetName: 文本型,已有的汇总工作表名,供跳过该工作表使用,如果不存在该工作表,请忽略参数或设置为"",默认为""
  8. 'ByColumn: 数值型,汇总依据的列号,受后面StartColumn影响,指汇总数据区中从StartColumn开始的第ByColumn个列为汇总依据,默认为第1列
  9. 'TitleRow: 数值型,明确标题行所在行号,默认为第1行
  10. 'BeginColumn: 数值型,有效数据区的起始列位置(可设置为跳过无效列,如序号列等),默认为第1列
  11. '***************************************************************************************************************
  12. Function MergeData(TotalWorkbookFullName As String, Optional TotalSheetName As String = "", Optional ByColumn As Long = 1, Optional TitleRow As Long = 1, Optional BeginColumn As Long = 1) As Variant
  13.     Dim Dic As Object, Arr, N&, I&, T&, Result, Str$, Str2$, WS As Worksheet
  14.     On Error GoTo Skip  '设置出错跳转
  15.     Set Dic = CreateObject("scripting.dictionary")  '创建字典项目,用于记录标题对应的列号及汇总关键字列对应的行号
  16.     T = 1  '初始化结果数组行号
  17.     With GetObject(TotalWorkbookFullName)  '根据传入的工作簿全路径名读取工作簿
  18.         For Each WS In .Worksheets  '循环各个工作表
  19.             If LCase(WS.Name) <> LCase(TotalSheetName) Then  '如果不是汇总工作表(注:TotalSheetName为""时也成立,将处理全部工作表)
  20.                 With WS
  21.                     Arr = .Range(.Cells(TitleRow, BeginColumn), .Cells.SpecialCells(xlCellTypeLastCell)).Value  '提取开始行列到已使用区域最末所在数据区到数组
  22.                     If Not IsArray(Result) Then ReDim Result(1 To .Rows.Count, LBound(Arr, 2) To UBound(Arr, 2))  '如果结果数组未初始化,则进行初始化操作
  23.                     For N = LBound(Arr) To UBound(Arr)  '循环数据各行
  24.                         Str2 = "R" & vbTab & Arr(N, ByColumn)  '组合关键列内容制作key,利用"R"标志标识行,与"C"标识的列区分
  25.                         For I = LBound(Arr, 2) To UBound(Arr, 2)  '循环数组各列
  26.                             If Arr(N, I) <> "" Then  '如果当前数据不为空,则
  27.                                 Str = "C" & vbTab & Arr(1, I)  '组合列标识key
  28.                                 If N = LBound(Arr) Then  '如果是标题行,则
  29.                                     If T = 1 Then Result(T, I) = Arr(LBound(Arr), I)  '如果是第一次执行,将当前数组标题写入
  30.                                     If Not Dic.exists(Str) Then  '如果不存在该列标识,则
  31.                                         If T = 1 Then  '如果是初次执行
  32.                                             Dic(Str) = I  '赋值为当前列号
  33.                                         Else  '如果是后期执行
  34.                                             ReDim Preserve Result(LBound(Result) To UBound(Result), LBound(Result, 2) To UBound(Result, 2) + 1)   '为结果数组增加一列
  35.                                             Result(LBound(Result), UBound(Result, 2)) = Arr(1, I)   '新增加的列标题为当前循环到的标题
  36.                                             Dic(Str) = UBound(Result, 2)  '记录下标题对应的列号
  37.                                         End If
  38.                                     End If
  39.                                 Else  '如果不是标题行,则
  40.                                     If Not Dic.exists(Str2) Then  '如果不存在对应关键字
  41.                                         Dic(Str2) = T  '记录该关键字对应的行号
  42.                                         Result(T, ByColumn) = Arr(N, ByColumn)  '写入对应的关键字到对应列中
  43.                                         T = T + 1  '行号移到下一空行
  44.                                     End If
  45.                                     If I <> ByColumn Then  '如果不是关键字列,则
  46.                                         If IsNumeric(Arr(N, I)) Then  '如果是数值则加和
  47.                                             Result(Dic(Str2), Dic(Str)) = Val(Result(Dic(Str2), Dic(Str))) + Val(Arr(N, I))
  48.                                         Else  '其他则只提取对应值
  49.                                             Result(Dic(Str2), Dic(Str)) = CStr(Arr(N, I))
  50.                                         End If
  51.                                     End If
  52.                                 End If
  53.                             End If
  54.                         Next I
  55.                         If T = 1 Then T = T + 1  '如果是初次执行,上方处理结束后下移一行
  56.                     Next N
  57.                 End With
  58.             End If
  59.         Next WS
  60.         If TotalWorkbookFullName <> ThisWorkbook.FullName Then .Close False  '如果不是当前工作簿则关闭并且不保存修改
  61.     End With
  62.     ReDim Arr(LBound(Result) To T - 1, LBound(Result, 2) To UBound(Result, 2))  '重置数组与结果数组列数相同,行数为有效行数
  63.     For I = LBound(Arr, 2) To UBound(Arr, 2)  '写入对应数据
  64.         For N = LBound(Arr) To UBound(Arr)
  65.             Arr(N, I) = Result(N, I)
  66.         Next N
  67.     Next I
  68.     MergeData = Arr  '返回结果
  69.     Set Dic = Nothing  '清空字典项目
  70.     Exit Function  '正常退出函数
  71. Skip:
  72.     Set Dic = Nothing  '出错时在这里清空字典项目
  73.     MergeData = "Error!"   '返回错误字符串
  74. End Function
调用代码示例如下:
  1. Sub test()
  2.     Dim Arr
  3.     Arr = MergeData(ThisWorkbook.FullName, "汇总", 2, , 2)   '直接写在工作簿内时可以这样用
  4.     'Arr = MergeData("D:\personal documents\连接.xlsx", "汇总", 2, , 2)    '汇总其他工作簿时可以这样用
  5.     With Worksheets("汇总")
  6.         If IsArray(Arr) Then
  7.             With .[b1].Resize(UBound(Arr), UBound(Arr, 2))
  8.                 .EntireColumn.ClearContents
  9.                 .NumberFormatLocal = "@"
  10.                 .Formula = Arr
  11.             End With
  12.         End If
  13.     End With
  14. End Sub
详见附件及素材源帖.

小麦&中麦.rar
2楼
DJ_Soo
这个有用,收藏!
3楼
张雄友
版主,如果不是汇总,而是合并怎么改?
4楼
老糊涂
下载收藏

免责声明

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

评论列表
sitemap