Excel 1-12月 不同表头标题(字段)数据合并(非常感谢zhaogang1960等老师)-ExcelVBA程序开发-ExcelHome技术论坛 -

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

新浪微博登陆

只需一步, 快速开始

    高级搜索
数据收集和协作,只需一张超级表格 魔方网表,Excel终结者,永久免费 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 快表——万能报表平台 Excel追价宝-用Excel追踪心仪商品价格 免费下载Excel行业应用视频
300集 易学宝-Office 2010微视频教程 财务会计玩转Excel - 报名进行中 免费阅读《Excel函数其实很简单》 7门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 6953|回复: 43

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2011-6-21 23:17 | 显示全部楼层 |阅读模式
问题:

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

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

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

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

谢谢!

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

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

7.01 KB, 下载次数: 200

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-22 09:01 | 显示全部楼层
抬一下,向老师们学习[em01]

TA的精华主题

TA的得分主题

发表于 2011-6-22 10:04 | 显示全部楼层

  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, 下载次数: 235

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-22 10:39 | 显示全部楼层
原帖由 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 编辑 ]

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-22 10:57 | 显示全部楼层
关闭了屏幕更新,发现速度提了一些,哈哈

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 编辑 ]

TA的精华主题

TA的得分主题

发表于 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 <> 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

TA的精华主题

TA的得分主题

发表于 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].End(xlToRight).Column)).ClearContents  '清除效果图A2以下内容
For Each sh In Sheets
    If sh.Name <> ActiveSheet.Name Then '工作表名不等于"效果图"
................
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-22 11:24 | 显示全部楼层
原帖由 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:

代码我测试了,非常不错的速度哦!

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-22 11:29 | 显示全部楼层
原帖由 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

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-6-25 18:05 | 显示全部楼层
原帖由 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:
加入了合并单元格和文字.jpg

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

14.02 KB, 下载次数: 103

您需要登录后才可以回帖 登录 | 免费注册 新浪微博登陆

本版积分规则

手机版|Archiver|关于我们|联系我们|ExcelHome ( 沪ICP备11019229号 )  
本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!
本站特聘法律顾问:徐怀玉律师 李志群律师

GMT+8, 2015-8-31 06:27 , Processed in 0.303018 second(s), 22 queries , Gzip On, Memcache On.

Powered by Discuz! X3.2

© 2001-2017 Wooffice Inc.

沪公网备       

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