正松舒，慢匀稳——太极字典少年班

name004

先敲个位置再说，今天才看到

节节高高

好东西啊，谢谢分享

fugue

占个位置，留待以后学习

feng16888

先下载，慢慢学习，支持版主

leroy

谢谢山版主，学习字典。

jiangwh15

版主辛苦了！真是个大好人哪！

ZJ325747

不是很懂，但版主做的很漂亮，谢谢分享

山菊花

最后一个实例，如果不使用字典，代码如下，供测试对比。

[code=vb] Sub 汇总2() '不使用字典，纯数组汇总
    Dim wb As Workbook, Sh As Worksheet
    Dim Arr(1 To 12, 0 To 5000, 1 To 256), Brr(), cPath$, cFile$, nS%, nS1%, nR%, nL%
    Application.ScreenUpdating = False
    cPath = ThisWorkbook.Path & "\"
    cFile = Dir(cPath & "*.xls*")
   
    Do While cFile <> ""
        If cFile <> ThisWorkbook.Name Then
            Set wb = GetObject(cPath & cFile) '打开数据工作簿
            For Each Sh In wb.Sheets '遍历工作表
                With Sh
                    Brr = .Range("a3").CurrentRegion '将数据读入数组
                    For nS1 = 1 To nS
                        If Arr(nS1, 0, 1) = .Name Then Exit For '查找工作表序号
                    Next
                    If nS1 > nS Then
                        nS = nS1: Arr(nS, 0, 1) = .Name
                    End If
                    For i = 2 To UBound(Brr)
                        If Right(Brr(i, 1), 1) <> "计" Then '剔除合计行
                            For nR = 2 To Arr(nS1, 0, 2)
                                If Arr(nS1, nR, 1) = Brr(i, 1) Then Exit For '查找行标题所在位置’如果使用字典，这里可以提高效率，节省时间
                            Next
                            If nR > Arr(nS1, 0, 2) Then
                                Arr(nS1, 0, 2) = nR: Arr(nS1, nR, 1) = Brr(i, 1) '将行标题写入数组
                            End If
                            For j = 2 To UBound(Brr, 2)
                                If Right(Brr(1, j), 1) <> "计" Then '剔除合计列
                                    For nL = 2 To Arr(nS1, 0, 3)
                                        If Arr(nS1, 1, nL) = Brr(1, j) Then Exit For '查找列标题所在位置’如果使用字典，这里可以提高效率，节省时间
                                    Next
                                    If nL > Arr(nS1, 0, 3) Then
                                        Arr(nS1, 0, 3) = nL: Arr(nS1, 1, nL) = Brr(1, j) '将列标题写入数组
                                    End If
                                    Arr(nS1, nR, nL) = Arr(nS1, nR, nL) + Brr(i, j) '汇总
                                End If
                            Next
                        End If
                    Next
                End With
            Next
            wb.Close (False)
        End If
        cFile = Dir
    Loop
    With Workbooks.Add  '新建工作簿
        For i = 1 To nS
            If .Sheets.Count < i Then .Sheets.Add after:=.Sheets(i) '插入工作表
            nR1 = Arr(i, 0, 2)
            nL1 = Arr(i, 0, 3)
            ReDim Brr(1 To nR1 + 1, 1 To nL1 + 1)
            For j = 1 To nR1
                For k = 1 To nL1
                    Brr(j, k) = Arr(i, j, k)
                Next
            Next
            Brr(1, 1) = "客户名称":        Brr(1, nL1 + 1) = "合计":        Brr(nR1 + 1, 1) = "合计"
            With .Sheets(i)
                .Name = Arr(i, 0, 1)
                .Range("a1").Resize(nR1 + 1, nL1 + 1) = Brr
                .Cells(2, nL1 + 1).Resize(nR1, 1).FormulaR1C1 = "=SUM(RC2:RC[-1])"
                .Cells(nR1 + 1, 2).Resize(1, nL1).FormulaR1C1 = "=SUM(R4C:R[-1]C)"
                Brr = .Range("a1").Resize(nR1 + 1, nL1 + 1).Value
                .Range("a1").Resize(nR1 + 1, nL1 + 1).Value = Brr
            End With
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "汇总完毕。      ", 64, "提示"
End Sub[/code]

望天打卦

总版主您好，谢谢你整理这么好的学习帖子。辛苦！辛苦。
第12个工作表事件我复制代码后运行的时候怎么提示错误阿。

endend1980

图文并茂，耳目一新，老师真是用心啊，辛苦了~~~