[已解决]灵活的多工作表合并或汇总

wenwen000424 · 发表于 2009-1-20 18:30

搜索了论坛，有很多关于工作表合并汇总的帖子，总感觉缺乏灵活性和通用性。现有一种思路请求高手帮助实现。先行谢过！

[ 本帖最后由 wenwen000424 于 2009-2-18 18:51 编辑 ]

山菊花 · 发表于 2009-1-21 10:23

wenwen000424_求助.zip (16.71 KB, 下载次数: 1265)

wenwen000424 · 发表于 2009-1-21 12:55

谢谢山版，基本实现了我的想法，缺憾的是表的列固定，不是根据要统计的工作表中不重复的列名自动得出的。希望能继续帮助。

qiujwen · 发表于 2009-1-21 13:32

认真学习

wenwen000424 · 发表于 2009-1-23 10:38

快过春节了,都忙着办年货去啦?没有人帮助解决,呜.....。无论如何，还是得先给大家拜个早年，祝大家新春快乐，牛年吉祥！

office2008 · 发表于 2009-1-23 13:52

Sub yy()
Dim i As Integer, k As Integer, r As Integer
Dim s As Integer, w As Integer, sh As Worksheet
Dim d As Object
Dim arr(), arr2()
Set d = CreateObject("scripting.dictionary")
With Sheets("汇总")
      For i = 1 To .Range("iv3").End(xlToLeft).Column
         s = s + 1
         d(.Cells(3, i).Value) = s                      '记录汇总最大列数以及列名
      Next
      For Each sh In Sheets
         If sh.Name <> "汇总" Then
            Set rng = .Range("a1:iv1").Find(sh.Name, , , 1)
            If rng.Offset(, 1).Value = "√" Then
                  r = sh.Range("a65536").End(xlUp).Row
                  If r > 1 Then
                     ar = sh.Range("a1:f" & r)          '下面有 If ar(1, w) <> "" Then 所以范围可以稍许大一点
                     For i = 2 To UBound(ar)
                        k = k + 1
                        ReDim Preserve arr(1 To s, 1 To k)
                        For w = 1 To UBound(ar, 2)
                              If ar(1, w) <> "" Then arr(d(ar(1, w)), k) = ar(i, w)
                        Next
                     Next
                  End If
            End If
         End If
      Next
      .Range("a17").Resize(UBound(arr, 2), 6) = Application.Transpose(arr) '这一段是合并

   Set d = CreateObject("scripting.dictionary")
      k = 0
      For i = 1 To UBound(arr, 2)
      If Not d.exists(arr(1, i)) Then
         k = k + 1
         d(arr(1, i)) = k
         ReDim Preserve arr2(1 To UBound(arr), 1 To k)
         For w = 1 To UBound(arr)
            arr2(w, d(arr(1, i))) = arr(w, i)
         Next
      Else
         For w = 2 To UBound(arr)
               arr2(w, d(arr(1, i))) = arr2(w, d(arr(1, i))) + arr(w, i)
         Next
      End If
      Next
      .Range("a4").Resize(UBound(arr2, 2), 6) = Application.Transpose(arr2)  '这一段是汇总
End With
End Sub

wenwen000424 · 发表于 2009-1-23 15:24

谢谢office2008的帮助，先祝新春愉快，合家欢乐。请问不管是合并还是汇总能否将每个合并或汇总表中的标题栏（各项的名目）自动由所选择的各表中提取出来吗？山版的程序也是这个方面没有解决，现在只是个示例，每个表的项目很少，实际应用中项目会经常变化，数目也经常变化且会很多，工作表数目也会比现在多，肯请继续帮助！

corvine99 · 发表于 2009-1-23 15:45

用我的roll up。。。它可以实现从不同工作簿中不同工作表中的任意range提取及汇总。。。。。。

wenwen000424 · 发表于 2009-1-23 15:58

谢谢你的回复,你的这工具我试过了,不是很明白,能否弄个中文的，另外能否按我的要求思考一下？现在主要是项目名称的提取问题有些难度。

office2008 · 发表于 2009-1-23 16:03

程序中不是用数据字典处理了吗？只要汇总的栏目包含所有项目名称，那么问题解决

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

[求助] [已解决]灵活的多工作表合并或汇总

回复 6楼 wenwen000424 的帖子

回复 10楼 wenwen000424 的帖子