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

wenwen000424

谢谢，可能我没有说清楚，现在程序处理的是已知了汇总表中第3行中的项目然后按对应项目进行统计。我的想法是第3行中项目不是事先填好的，而是由第一行所选择的工作表中的项目自动提取的不重复项目然后自动填充到第3行的，是动态的。

office2008

呵呵，办法很简单
１　在程序之前再先字典一下（把所有项目都搞到）
２　索性用ＡＤＯ+ＳＱＬ应该不难，几个表的循环　（有个前提：表多吗？）

wenwen000424

本人有此莱,能否请用我给的附件做个例子给我,谢谢!真不好意思.

office2008

呵呵，我还欠着几个朋友的帐呢？（答应帮他们做的，可现在只能偶尔上来，忙啊），今天有空．
好，可以的，不过要在晚上，今天有客到，须去准备小菜了．

zhaogang1960

借用office2008的代码，试试看是否合乎要求：
Sub yy()
    Dim i As Integer, k As Integer, r As Integer, lc As Integer
    Dim s As Integer, w As Integer, sh As Worksheet
    Dim d As Object
    Dim arr(), arr2(), brr
    Set d = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            With sh
                lc = .Range("iv1").End(xlToLeft).Column
                brr = .Range(.Cells(1, 1), .Cells(1, lc))
                For i = 2 To lc - 1
                    d(brr(1, i)) = ""
                Next i
            End With
        End If
    Next sh
    lc = d.Count + 2 '表头列数
    Application.ScreenUpdating = False
    '以下4行写表头，其中16及后面的17可以根据实际重新设置
    Cells(3, 1) = "姓名": Cells(3, lc) = "合计"
    Cells(3, 2).Resize(1, d.Count) = d.keys
    Cells(16, 1) = "姓名": Cells(16, lc) = "合计"
    Cells(16, 2).Resize(1, d.Count) = d.keys
    d.RemoveAll
    On Error Resume Next
    Set d = CreateObject("scripting.dictionary")
    With Sheets("汇总")
        brr = .Range(.Cells(3, 1), .Cells(3, lc))
        For i = 1 To lc
            d(brr(1, i)) = i                         '记录汇总最大列数以及列名
        Next
        lc2 = .Range("iv1").End(xlToLeft).Column
        brr = .Range(.Cells(1, 1), .Cells(1, lc2))
        For i = 1 To lc2 - 1 Step 2
            If brr(1, i + 1) = "√" Then
                If Len(Sheets(brr(1, i)).Name) > 0 Then
                    If Err = 0 Then
                        With Sheets(brr(1, i))
                            r = .Range("a65536").End(xlUp).Row
                            If r > 1 Then
                                ar = .Range(.Cells(1, 1), .Cells(r, lc))
                                For j = 2 To r
                                    k = k + 1
                                    ReDim Preserve arr(1 To lc, 1 To k)
                                    For w = 1 To lc
                                        If ar(1, w) <> "" Then arr(d(ar(1, w)), k) = ar(j, w)
                                    Next w
                                Next j
                            End If
                        End With
                    End If
                End If
            End If
        Next i
        .Range("a17").Resize(.UsedRange.Rows.Count, lc).Clear
        .Range("a17").Resize(UBound(arr, 2), lc) = Application.Transpose(arr)   '这一段是合并
        .Range("a16").Resize(UBound(arr, 2) + 1, lc).Borders.LineStyle = xlContinuous
        .Range("a16").Resize(1, lc).Interior.ColorIndex = 15
        d.RemoveAll
       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(12, lc).Clear '12根据实际情况设定
        .Range("a4").Resize(UBound(arr2, 2), lc) = Application.Transpose(arr2)  '这一段是汇总
        .Range("a3").Resize(UBound(arr2, 2) + 1, lc).Borders.LineStyle = xlContinuous
        .Range("a3").Resize(1, lc).Interior.ColorIndex = 15
End With
Application.ScreenUpdating = True
End Sub
求助.rar (12.39 KB, 下载次数: 659)

2009-1-23 17:03 上传

点击文件名下载附件

wenwen000424

非常感谢，可不要喝醉酒，把我的事忘了呀！嘻嘻。

wenwen000424

非常感谢zhaogang1960 ，非常满意。有个问题想再次问一下，第一行的sheet项数与“√”有什么更好的办法根据当前工作薄的工作表名称自动生成吗？

zhaogang1960

似乎没有自动生成的必要，只要汇总除“汇总”之外的所有工作表即可
Sub 自动生成第一行()
    Dim sh As Worksheet, arr(), m As Integer
    ReDim arr(1 To (Sheets.Count - 1) * 2)
    m = -1
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            m = m + 2
            arr(m) = sh.Name
            arr(m + 1) = "√"
        End If
    Next
    Rows(1).ClearContents
    Range("a1").Resize(1, m + 1) = arr
End Sub

wenwen000424

再次表示感谢，非常满意。

office2008

..............

[ 本帖最后由 office2008 于 2009-1-23 19:07 编辑 ]