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

楼主 kevinchengcw	Q: 如何利用vba自定义不定标题列多表合并函数？ A: 实现代码如下： '************************************************************************************************************* 'MergeData 多工作表汇总函数,对多个格式相同的工作表进行汇总 '要求: 标准二维表格,工作表的标题行位置一致,要汇总的数据起始列位置一致,关键字列的位置一致 '返回值: 汇总后结果的数组或出错时返回文本"Error!" '参数说明: 'TotalWorkbooFullName: 文本型,要汇总的工作簿全路径名(可以是打开或未打开的工作簿) 'TotalSheetName: 文本型,已有的汇总工作表名,供跳过该工作表使用,如果不存在该工作表,请忽略参数或设置为"",默认为"" 'ByColumn: 数值型,汇总依据的列号,受后面StartColumn影响,指汇总数据区中从StartColumn开始的第ByColumn个列为汇总依据,默认为第1列 'TitleRow: 数值型,明确标题行所在行号,默认为第1行 'BeginColumn: 数值型,有效数据区的起始列位置(可设置为跳过无效列,如序号列等),默认为第1列 '************************************************************************************************************* 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 Dim Dic As Object, Arr, N&, I&, T&, Result, Str$, Str2$, WS As Worksheet On Error GoTo Skip '设置出错跳转 Set Dic = CreateObject("scripting.dictionary") '创建字典项目,用于记录标题对应的列号及汇总关键字列对应的行号 T = 1 '初始化结果数组行号 With GetObject(TotalWorkbookFullName) '根据传入的工作簿全路径名读取工作簿 For Each WS In .Worksheets '循环各个工作表 If LCase(WS.Name) <> LCase(TotalSheetName) Then '如果不是汇总工作表(注:TotalSheetName为""时也成立,将处理全部工作表) With WS Arr = .Range(.Cells(TitleRow, BeginColumn), .Cells.SpecialCells(xlCellTypeLastCell)).Value '提取开始行列到已使用区域最末所在数据区到数组 If Not IsArray(Result) Then ReDim Result(1 To .Rows.Count, LBound(Arr, 2) To UBound(Arr, 2)) '如果结果数组未初始化,则进行初始化操作 For N = LBound(Arr) To UBound(Arr) '循环数据各行 Str2 = "R" & vbTab & Arr(N, ByColumn) '组合关键列内容制作key,利用"R"标志标识行,与"C"标识的列区分 For I = LBound(Arr, 2) To UBound(Arr, 2) '循环数组各列 If Arr(N, I) <> "" Then '如果当前数据不为空,则 Str = "C" & vbTab & Arr(1, I) '组合列标识key If N = LBound(Arr) Then '如果是标题行,则 If T = 1 Then Result(T, I) = Arr(LBound(Arr), I) '如果是第一次执行,将当前数组标题写入 If Not Dic.exists(Str) Then '如果不存在该列标识,则 If T = 1 Then '如果是初次执行 Dic(Str) = I '赋值为当前列号 Else '如果是后期执行 ReDim Preserve Result(LBound(Result) To UBound(Result), LBound(Result, 2) To UBound(Result, 2) + 1) '为结果数组增加一列 Result(LBound(Result), UBound(Result, 2)) = Arr(1, I) '新增加的列标题为当前循环到的标题 Dic(Str) = UBound(Result, 2) '记录下标题对应的列号 End If End If Else '如果不是标题行,则 If Not Dic.exists(Str2) Then '如果不存在对应关键字 Dic(Str2) = T '记录该关键字对应的行号 Result(T, ByColumn) = Arr(N, ByColumn) '写入对应的关键字到对应列中 T = T + 1 '行号移到下一空行 End If If I <> ByColumn Then '如果不是关键字列,则 If IsNumeric(Arr(N, I)) Then '如果是数值则加和 Result(Dic(Str2), Dic(Str)) = Val(Result(Dic(Str2), Dic(Str))) + Val(Arr(N, I)) Else '其他则只提取对应值 Result(Dic(Str2), Dic(Str)) = CStr(Arr(N, I)) End If End If End If End If Next I If T = 1 Then T = T + 1 '如果是初次执行,上方处理结束后下移一行 Next N End With End If Next WS If TotalWorkbookFullName <> ThisWorkbook.FullName Then .Close False '如果不是当前工作簿则关闭并且不保存修改 End With ReDim Arr(LBound(Result) To T - 1, LBound(Result, 2) To UBound(Result, 2)) '重置数组与结果数组列数相同,行数为有效行数 For I = LBound(Arr, 2) To UBound(Arr, 2) '写入对应数据 For N = LBound(Arr) To UBound(Arr) Arr(N, I) = Result(N, I) Next N Next I MergeData = Arr '返回结果 Set Dic = Nothing '清空字典项目 Exit Function '正常退出函数 Skip: Set Dic = Nothing '出错时在这里清空字典项目 MergeData = "Error!" '返回错误字符串 End Function 调用代码示例如下: Sub test() Dim Arr Arr = MergeData(ThisWorkbook.FullName, "汇总", 2, , 2) '直接写在工作簿内时可以这样用 'Arr = MergeData("D:\personal documents\连接.xlsx", "汇总", 2, , 2) '汇总其他工作簿时可以这样用 With Worksheets("汇总") If IsArray(Arr) Then With .[b1].Resize(UBound(Arr), UBound(Arr, 2)) .EntireColumn.ClearContents .NumberFormatLocal = "@" .Formula = Arr End With End If End With End Sub 详见附件及素材源帖. 小麦&中麦.rar
2楼 DJ_Soo	这个有用,收藏!
3楼张雄友	版主，如果不是汇总，而是合并怎么改？
4楼老糊涂	下载收藏