1-12月不同表头标题（字段）数据合并(非常感谢zhaogang1960等老师)

商人 · 发表于 2011-6-21 23:17

问题：

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

2、每个月的表头标题（字段），不一定相同，数量也不一定一样。

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

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

谢谢！

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

商人 · 发表于 2011-6-22 09:01

抬一下，向老师们学习

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 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
End Sub

复制代码

商人 · 发表于 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 编辑 ]

商人 · 发表于 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

还有啥高招？

[ 本帖最后由商人于 2011-6-22 11: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 <> 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

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

商人 · 发表于 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....

代码我测试了，非常不错的速度哦！

商人 · 发表于 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]. ...

学习了

商人 · 发表于 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)) 的表达，可是没完成。
请老师帮忙指点下，非常感谢！

		自动登录	找回密码
密码			免费注册

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

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