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

wenwen000424

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

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

山菊花

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

2009-1-21 10:23 上传

点击文件名下载附件

wenwen000424

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

qiujwen

认真学习

wenwen000424

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

office2008

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

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

corvine99

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

wenwen000424

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

office2008

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