楼主 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 |