VBA透视表式汇总

Sub 透视表式汇总()
        Dim d As Object, arr, x&, y%, s, t, a, b, m%, n%, r%
        Dim sh  As Worksheet
        Application.ScreenUpdating = False
        Set d = CreateObject("scripting.dictionary")
        Application.DisplayAlerts = False
        For Each sh In Worksheets
             If Not sh.Name Like "合并结果" Then
                     sh.Delete
             End If
        Next sh
        Application.DisplayAlerts = True
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = "透视表式汇总"
        Sheets("合并结果").Activate
        arr = Range("a1").CurrentRegion
        For x = 2 To UBound(arr)
                If Not d.exists(arr(x, 4)) Then
                        Set d(arr(x, 4)) = CreateObject("scripting.dictionary")
                End If
                d(arr(x, 4))(arr(x, 12)) = d(arr(x, 4))(arr(x, 12)) + arr(x, 9)
        Next x
                s = d.keys: t = d.items
        Sheets("透视表式汇总").Activate
        For m = 0 To d.Count - 1
                a = d(s(m)).keys: b = d(s(m)).items
                n = n + r
                With Sheets("透视表式汇总")
                        .Cells(1, 1).Resize(1, 3) = Array("门店", "型号", "数量")
                        .Cells(2 + n, 1).Resize(d(s(m)).Count, 1) = s(m)
                        .Cells(2 + n, 2).Resize(d(s(m)).Count, 1) = Application.Transpose(a)
                        .Cells(2 + n, 3).Resize(d(s(m)).Count, 1) = Application.Transpose(b)
                        n = 0
                End With
                r = Cells(Rows.Count, 1).End(xlUp).Row - 1
        Next m
        Range("a:c").EntireColumn.AutoFit
        Application.ScreenUpdating = True
End Sub