Microsoft技术社区联盟成员,全球领先的Excel门户,Office培训学习的最佳社区
加关注|繁體中文 切换到窄版

ExcelHome技术论坛

 找回密码
 免费注册

用新浪微博连接

一步搞定

QQ登录

只需一步,快速开始

魔方网表,Excel终结者,永久免费 Excel服务器学习和下载-做管理系统 Excel Home官方微博精品教程库
Excel不给力? 何不试试FoxTable! 2014年下半年Excel免费培训班计划 Excel协同平台+ERP标准框架+免费设计模板 免费下载Excel行业应用视频教程
Excel 2007表格基本操作秘技 免费学习Word 2007实战技巧视频 前所未见,90集Excel2010视频教程公开 最权威、易懂的VBA学习宝典
超级强悍, 无比易用的 Excel 工具集 你的Excel 2010函数公式学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
  • 904财富
  • 1鲜花
  • 0技术
    • 等级 2EH初级
    积分排行
    4913
    帖子
    253
    精华
    0
    微积分
    0
    发表于 2011-6-21 23:17:18 |显示全部楼层
    分享到:

    [已解决] 1-12月 不同表头标题(字段)数据合并(非常感谢zhaogang1960等老师) [复制链接]

    问题:

    1、如何把1-12个月的数据汇总整合在这样一个表格里,这个效果图是透视表做的。

    2、每个月的表头标题(字段),不一定相同,数量也不一定一样。

    3、能合并同一工作簿里的所有表格。

    效果图的第一行就是整合了所有要合并的12个月的表格的表头字段的唯一值。其他数据,依次写入。

    谢谢!

    [ 本帖最后由 商人 于 2011-6-26 20:04 编辑 ]

    1-12月 不同表头标题(字段)数据合并.rar

    7.01 KB, 下载次数: 192

  • 904财富
  • 1鲜花
  • 0技术
    • 等级 2EH初级
    积分排行
    4913
    帖子
    253
    精华
    0
    微积分
    0
    发表于 2011-6-22 09:01:22 |显示全部楼层
    抬一下,向老师们学习[em01]
  • 21027财富
  • 281鲜花
  • 0技术
  • 积分排行
    161
    帖子
    5519
    精华
    0
    微积分
    0
    发表于 2011-6-22 10:04:43 |显示全部楼层
    1. Private Sub CommandButton1_Click()
    2. Dim sh As Worksheet, r As Long, i As Integer, j As Long
    3. For Each sh In Sheets
    4.     If sh.Name <> ActiveSheet.Name Then '工作表名不等于"效果图"
    5.         For j = 2 To sh.[A65536].End(xlUp).Row  '各工作表从第2列到最后有数据列循环
    6.                 r = [A65536].End(xlUp).Row + 1  '"效果图"最后有数据列加1
    7.             For i = 4 To [A1].End(xlToRight).Column '"效果图"D1~G1 差旅费.......
    8.                 Cells(r, 1).Resize(, 3) = Array(sh.Name, sh.Cells(j, 1), sh.Cells(j, 2))    '"效果图"新增一列"工作表名,序号,姓名"
    9.                 Set c = sh.UsedRange.Find(Cells(1, i))  '查工作表表头和"效果图"相同栏位字段
    10.                 If Not c Is Nothing Then
    11.                     Cells(r, i) = c.Offset(j - 1, 0)    '找到相同栏位行数就填入对应数据
    12.                 Else
    13.                     Cells(r, i) = 0 '不到到就填入"0"
    14.                 End If
    15.             Next i
    16.         Next j
    17.     End If
    18. Next sh
    19. End Sub
    复制代码

    1-12月 不同表头标题(字段)数据合并.rar

    16.92 KB, 下载次数: 215

  • 904财富
  • 1鲜花
  • 0技术
    • 等级 2EH初级
    积分排行
    4913
    帖子
    253
    精华
    0
    微积分
    0
    发表于 2011-6-22 10:39:23 |显示全部楼层
    原帖由 mineshine 于 2011-6-22 10:04 发表

    Private Sub CommandButton1_Click()
    Dim sh As Worksheet, r As Long, i As Integer, j As Long
    For Each sh In Sheets
        If sh.Name  ActiveSheet.Name Then '工作表名不等于"效果图"
            For j = 2 T ...



    谢谢老师的帮忙指点,基本能实现了,哈哈。

    不过我还有个小小两点要求:

    1、汇总表里,能不能直接筛选出 12个月表格的标题字段的唯一值,意思当任意再增加的时候(比如在1月表格里新加入“运输费”字段),则运行VBA自动再增加入汇总表第一行。

    2、汇总的速度我这里好像有些儿慢,不知还有提升空间不?

    [ 本帖最后由 商人 于 2011-6-22 10:40 编辑 ]
  • 904财富
  • 1鲜花
  • 0技术
    • 等级 2EH初级
    积分排行
    4913
    帖子
    253
    精华
    0
    微积分
    0
    发表于 2011-6-22 10:57:41 |显示全部楼层
    关闭了屏幕更新,发现速度提了一些,哈哈

    Private Sub CommandButton1_Click()
        Dim sh As Worksheet, r As Long, i As Integer, j As Long
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        ActiveSheet.Rows("2:65536").Clear
        For Each sh In Sheets
            If sh.Name <> ActiveSheet.Name Then    '工作表名不等于"效果图"
                For j = 2 To sh.[A65536].End(xlUp).Row  '各工作表从第2列到最后有数据列循环
                    r = [A65536].End(xlUp).Row + 1  '"效果图"最后有数据列加1
                    For i = 4 To [A1].End(xlToRight).Column    '"效果图"D1~G1 差旅费.......
                        Cells(r, 1).Resize(, 3) = Array(sh.Name, sh.Cells(j, 1), sh.Cells(j, 2))    '"效果图"新增一列"工作表名,序号,姓名"
                        Set c = sh.UsedRange.Find(Cells(1, i))  '查工作表表头和"效果图"相同栏位字段
                        If Not c Is Nothing Then
                            Cells(r, i) = c.Offset(j - 1, 0)    '找到相同栏位行数就填入对应数据
                        Else
                            Cells(r, i) = 0    '不到到就填入"0"
                        End If
                    Next i
                Next j
            End If
        Next sh
        Application.ScreenUpdating = True
        Application.EnableEvents = True

    End Sub

    还有啥高招?[em07]

    [ 本帖最后由 商人 于 2011-6-22 11:02 编辑 ]
  • 135979财富
  • 8949鲜花
  • 56技术
  • 积分排行
    4
    昵称
    请模拟效果
    帖子
    38322
    精华
    2
    微积分
    0

    大侠勋章 最佳管理者 最佳管理者 最佳管理者 最佳管理者 金牌优秀管理者 优秀管理者 金牌优秀会员 金牌优秀会员 优秀会员 优秀会员

    发表于 2011-6-22 11:11:02 |显示全部楼层
    试试看
    Sub Macro1()
        Dim arr, brr(), sh As Worksheet, i&, j&, s$, d As Object
        Set d = CreateObject("scripting.dictionary")
        For Each sh In Sheets
            With sh
                If .Name <> ActiveSheet.Name Then
                    arr = .[a1].CurrentRegion
                    For j = 1 To UBound(arr, 2)
                        If Not d.Exists(arr(1, j)) Then
                            m = m + 1
                            d(arr(1, j)) = m
                        End If
                    Next
                End If
            End With
        Next
        ReDim brr(1 To 60000, d.Count)
        m = 0
        For Each sh In Sheets
            With sh
                If .Name <> ActiveSheet.Name Then
                    s = .Name
                    arr = .[a1].CurrentRegion
                    For i = 2 To UBound(arr)
                        m = m + 1
                        brr(m, 0) = s
                        For j = 1 To UBound(arr, 2)
                            brr(m, d(arr(1, j))) = arr(i, j)
                        Next
                    Next
                End If
            End With
        Next
        ActiveSheet.UsedRange.ClearContents
        [a1] = "工作表"
        [b1].Resize(, d.Count) = d.keys
        [a2].Resize(m, d.Count + 1) = brr
    End Sub
  • 21027财富
  • 281鲜花
  • 0技术
  • 积分排行
    161
    帖子
    5519
    精华
    0
    微积分
    0
    发表于 2011-6-22 11:11:48 |显示全部楼层
    2.每个表格式不同,速度上要提升可能有难度,看有没有其他有别的方法。

    Private Sub CommandButton1_Click()
    Dim sh As Worksheet, r As Long, i As Integer, j As Long
    Range(Cells(2, 1), Cells(65536, [a1].End(xlToRight).Column)).ClearContents  '清除效果图A2以下内容
    For Each sh In Sheets
        If sh.Name <> ActiveSheet.Name Then '工作表名不等于"效果图"
    ................
    End Sub
  • 904财富
  • 1鲜花
  • 0技术
    • 等级 2EH初级
    积分排行
    4913
    帖子
    253
    精华
    0
    微积分
    0
    发表于 2011-6-22 11:24:00 |显示全部楼层
    原帖由 zhaogang1960 于 2011-6-22 11:11 发表
    试试看
    Sub Macro1()
        Dim arr, brr(), sh As Worksheet, i&, j&, s$, d As Object
        Set d = CreateObject("scripting.dictionary")
        For Each sh In Sheets
            With sh
                If .Name   ...


    谢谢赵刚老师,从SQL透视到这里,又一次得到您的帮助了,感动ing.... :hug:

    代码我测试了,非常不错的速度哦!
  • 904财富
  • 1鲜花
  • 0技术
    • 等级 2EH初级
    积分排行
    4913
    帖子
    253
    精华
    0
    微积分
    0
    发表于 2011-6-22 11:29:30 |显示全部楼层
    原帖由 mineshine 于 2011-6-22 11:11 发表
    2.每个表格式不同,速度上要提升可能有难度,看有没有其他有别的方法。

    Private Sub CommandButton1_Click()
    Dim sh As Worksheet, r As Long, i As Integer, j As Long
    Range(Cells(2, 1), Cells(65536, [a1]. ...


    学习了 :handshake
  • 904财富
  • 1鲜花
  • 0技术
    • 等级 2EH初级
    积分排行
    4913
    帖子
    253
    精华
    0
    微积分
    0
    发表于 2011-6-25 18:05:02 |显示全部楼层
    原帖由 zhaogang1960 于 2011-6-22 11:11 发表
    试试看
    Sub Macro1()
        Dim arr, brr(), sh As Worksheet, i&, j&, s$, d As Object
        Set d = CreateObject("scripting.dictionary")
        For Each sh In Sheets
            With sh
                If .Name   ...


    我再提出个新问题,如果标题字段行是从B3单元格开始的,而且,B3上方是合并单元格并且有文字。又该如何修改代码呢?
    改成:
    arr = .[b3].CurrentRegion   是不能解决的,因为上面有合并单元格且有文字。

    如何动态表示出B3向下和向右的有效数值区域?我尝试用 range(cells(x1,y1),cells(x2,y2)) 的表达,可是没完成。
    请老师帮忙指点下,非常感谢!:hug:
    1-12月 不同表头标题(字段)数据合并(非常感谢zhaogang1960等老师) - ExcelHome - 加入了合并单元格和文字.jpg

    1-12月 不同表头标题(字段)数据合并-加入合并单元格标题.rar

    14.02 KB, 下载次数: 88

    发表回复

    您需要登录后才可以回帖 登录 | 免费注册

    发帖时请遵守我国法律,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任。
    关闭

    最新热点

    关于发帖要求邮箱认证的说明
    - 注意:自2014/8/1起,未完成邮箱认证的会员将无法发帖!
    如何完成邮箱认证?请点击下方“查看”。

    查看 »

    回顶部