|
|
本帖最后由 qdchyq 于 2020-3-7 19:49 编辑
老师，我的excel表格的表头顺序不一致，想合并，我有一段代码，只能处理表头是一行，现在我的Excel表格的表头是两行就不行了，烦请老师指点一下，谢谢
Sub 数据合并()
Dim f_Tab, z_Title, z_T_Lists, z_T, 总表表头行, 总表列数, 分表表头行, 分表尾行
Dim 来源计数, t, f_T_any, ele, z_to_fcol, Title_Cnt, i, j, m, n%, instrSs$, s$
Dim sh As Worksheet, wb As Workbook, 选择 As Range, 分表尾单元格 As Range, dic
Dim 分表列数&, 分表行数&, tmp%
总表表头行 = 1
'获取总表列数 '**************************
z_Title = Range(Cells(总表表头行, 1), Cells(总表表头行, Cells(总表表头行, Columns.count).End(xlToLeft).Column)).Value
If Not IsArray(z_Title) Then: MsgBox "总表第一行为表头行，至少填写两个字段名！": Exit Sub: Else: 总表列数 = UBound(z_Title, 2)
For i = 1 To 总表列数
If InStr(Cells(总表表头行, i), "来源") Then 来源计数 = 来源计数 + 1
Next
If 来源计数 = 0 Then 总表列数 = 总表列数 + 3
'定义总表结果数组 '*******************************
ReDim z_Tab(1 To rows.count, 1 To 总表列数)
If MsgBox("您确定现在开始合并本工作簿下的全部工作表吗", vbYesNo + vbQuestion, "确认") <> vbYes Then Exit Sub
'------------------------------
Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
For Each sh In Sheets
If sh.Name <> ActiveSheet.Name Then
'分表表头行号'出现次数最多的为表头行,防止其它行有与表头有相似名称
For j = 1 To UBound(z_Title, 2)
If z_Title(1, j) <> "" Then
z_T_Lists = Split(Replace(z_Title(1, j), "、", "/"), "/")
'当总表字段名可以拆分为多个名称时，循环，z_T为拆分出来的字段名
For Each z_T In z_T_Lists
'记录总表字段名在分表中的行号，并计算出现次数
Set f_T_any = sh.Cells.Find(z_T, , xlFormulas, xlPart, xlByRows, xlNext, False, False, False) '分表表头单元格
If Not f_T_any Is Nothing Then
dic(f_T_any.Row) = dic(f_T_any.Row) + 1 '疑似分表表头的行 计数
End If
Next
End If
Next
For Each ele In dic.keys
If dic(ele) = Application.Max(dic.items) Then 分表表头行 = ele: Exit For
Next
dic.RemoveAll
'分表列数、尾行、数据 '*************************
If 分表表头行 > 0 Then
Set 分表尾单元格 = sh.Cells.Find("*", , xlFormulas, xlPart, xlRows, xlPrevious, False, False, False)
If Not 分表尾单元格 Is Nothing Then
分表尾行 = 分表尾单元格.Row
分表列数 = sh.Cells(分表表头行, sh.Columns.count).End(xlToLeft).Column
f_Tab = sh.Range(sh.Cells(分表表头行, 1), sh.Cells(分表尾行, 分表列数)).Value
分表行数 = UBound(f_Tab, 1)
ReDim z_to_fcol(1 To 总表列数 - 3) '临时存放总表表头在分表中的列号
'总表表头在分表中的列号(z_to_fcol) ，此处数组来解决，也可以改为字典精确匹配'**************
For i = 1 To UBound(z_to_fcol)
For j = 1 To 分表列数
If f_Tab(1, j) <> "" Then
'分表如果有重复表头或有近似的表头，将取第一个。如总表表头是"客户"，
'分表中第2列是"客户姓名"，第3列是"姓名"，则取"客户姓名"列的数据。
If z_to_fcol(i) = 0 And Trim(z_Title(1, i)) = Trim(f_Tab(1, j)) Then z_to_fcol(i) = j: Title_Cnt = Title_Cnt + 1: Exit For '精确匹配
End If
Next
Next
'待增功能，合并分表中无表头的列数据
n = n + 1 'sh计数
'分表数据写入总表数组
If Title_Cnt > 0 Then
For i = 2 To 分表行数
m = m + 1
'序号和数据来源
z_Tab(m, 总表列数 - 2) = m '序号
z_Tab(m, 总表列数 - 1) = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1) '来源工作簿
z_Tab(m, 总表列数) = sh.Name '来源工作表
'数据
For j = 1 To 总表列数 - 3
If Not IsEmpty(z_to_fcol(j)) Then
z_Tab(m, j) = f_Tab(i, z_to_fcol(j))
instrSs = instrSs & f_Tab(i, z_to_fcol(j))
End If
Next
If Len(instrSs) = 0 Then
m = m - 1
End If
instrSs = ""
Next
End If
'清空分表表头与总表表头对应关系数组
Erase z_to_fcol: Title_Cnt = 0
End If
End If
End If
Next
'输出*********************************
If m > 0 Then
Cells(总表表头行 + 1, 1).Resize(rows.count - 总表表头行, Columns.count).ClearContents
'常规格式
Range("A2:iv" & m + 1).NumberFormatLocal = "@"
'设置文本格式,超过15位的数字建议设置文本格式
' Range("c2:c" & m + 1).NumberFormatLocal = "@"
rows(m + 2 & ":" & rows.count).Delete
Cells(总表表头行, 1).Offset(, 总表列数 - 3).Resize(1, 3) = Array("序号", "来源工作簿", "来源工作表")
Cells(总表表头行 + 1, 1).Resize(m, 总表列数) = z_Tab
End If
'提示信息***********************
s = " 合并完成！共合并了" & n & "个工作表，共" & m & "行数据。"
s = s & vbCrLf & "说明：1.用微软的EXCEL打开并启用宏，WPS未测试；Q群12393933"
s = s & vbCrLf & " 2.在本表中填写好要合并的列字段名称，例如本表的第1行，最后3列自动生成；"
s = s & vbCrLf & " 3.分表中列字段名要与总表相同或是包含关系，如总表A1可以写成：客户姓名/姓名/顾客姓名(用/或、号分隔)，"
s = s & "分表中是姓名、客户姓名或顾客姓名其中一种都可以匹配；各分表中表头位置和顺序可以不相同；"
MsgBox s, vbInformation, "提示"
If m + 2 <= 16 Then
rows("16:" & rows.count).Delete
Else
rows(m + 2 & ":" & rows.count).Delete
End If
Application.ScreenUpdating = True
End Sub
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-3-7 19:26
楼主