ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 327|回复: 4

[求助] 表头顺序不一致提取数据,请老师帮忙

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-3-7 19:26 | 显示全部楼层 |阅读模式
本帖最后由 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

Book2.zip

4.51 KB, 下载次数: 21

TA的精华主题

TA的得分主题

发表于 2020-3-11 08:40 | 显示全部楼层
直接在代码改不就完事了 自动动手丰衣足食

TA的精华主题

TA的得分主题

发表于 2020-3-11 09:37 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-3-20 19:18 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-4-23 21:16 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-5-31 15:57 , Processed in 0.065772 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表