'4，多工作表汇总（字典、数组）

'http://club.excelhome.net/viewthread.php?tid=450709&pid=2928374&page=1_

&extra=page%3D1

'Data多表汇总0623.xls

Sub dbhz()

'多表汇总

Dim Sht1 As Worksheet, Sht2 As Worksheet, ShtAs Worksheet

Dim d, k, t, Myr&, Arr, x

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Set d =CreateObject("Scripting.Dictionary")

For Each Sht InSheets     '删除同名的表格，获得要增加的汇总表格不重复名字

    If InStr(Sht.Name,"-") > 0 Then

    Sht.Delete: GoTo 100

    nm = Mid(Sht.[a3], 7)

    d(nm) = ""

100:

Next Sht

Application.DisplayAlerts = True

k = d.keys

For i = 0 To UBound(k)

    Sheets.Addafter:=Sheets(Sheets.Count)

    Set Sht1 = ActiveSheet

Sht1.Name =Replace(k(i), "/", "-") 

'增加汇总表，把名字中的"/"（不能用作表名的）改为"-"

Next i

Erase k

Set d = Nothing

For Each Sht In Sheets

    With Sht

       .Activate

       If InStr(.Name, "-") = 0 Then

           nm = Replace(Mid(.[a3], 7), "/", "-")

           Myr = .[h65536].End(xlUp).Row

           Arr = .Range("d10:h" & Myr)

           Set d = CreateObject("Scripting.Dictionary")

           For i = 1 To UBound(Arr)

               x = Arr(i, 1)

               If Not d.exists(x) Then

                   d.Add x, Arr(i, 5)

               Else

                    d(x)= d(x) + Arr(i, 5)

               End If

           Next

           k = d.keys

           t = d.items

           Set Sht2 = Sheets(nm)

           Sht2.Activate

           Myr2 = [a65536].End(xlUp).Row + 1

           If Myr2 < 9 Then

               Cells(9, 1).Resize(1, 2) = Array("PartNo.", "TTL Qty")

               Cells(10, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)

               Cells(10, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t)

           Else

               Cells(Myr2, 1).Resize(UBound(k) + 1, 1) = Application.Transpose(k)

               Cells(Myr2, 2).Resize(UBound(t) + 1, 1) = Application.Transpose(t)

           End If

           Erase k

           Erase t

           Set d = Nothing

       End If

    End With

Next Sht

Application.ScreenUpdating = True

End Sub