VBA多工作表求和问题

quqiyuan

代码如下。。。
Sub test()
    Set ws = ThisWorkbook
    Set sht = ws.Sheets("Master")
    arr = sht.[a4].CurrentRegion
    ReDim crr(1 To 8)
    For j = 1 To 8
        crr(j) = arr(1, j) & arr(2, j)
    Next
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To 10000, 1 To 8)
    For Each sh In ws.Sheets
        If sh.Name <> sht.Name Then
            Set Rng = sh.UsedRange.Find("PN", LookIn:=xlValues, lookat:=xlWhole)
            Set rn = Rng.End(4)
            arr = sh.Range(Rng.Offset(-1), rn).Resize(, 5)
            For i = 3 To UBound(arr)
                If arr(i, 1) <> Empty Then
                    s = arr(i, 1) & "|" & arr(i, 2)
                    If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
                    If Not d(s).exists(arr(i, 3)) Then
                        Set d(s)(arr(i, 3)) = CreateObject("scripting.dictionary")
                        d(s)(arr(i, 3))(arr(1, 4)) = arr(i, 4)
                        d(s)(arr(i, 3))(arr(1, 5)) = arr(i, 5)
                    Else
                        d(s)(arr(i, 3))(arr(1, 4)) = d(s)(arr(i, 3))(arr(1, 4)) + arr(i, 4)
                        d(s)(arr(i, 3))(arr(1, 5)) = d(s)(arr(i, 3))(arr(1, 5)) + arr(i, 5)
                    End If
                End If
            Next
        End If
    Next
    Item = d.items
    For Each k In d.keys
        n = n + 1
        it = Split(k, "|")
        brr(n, 1) = it(0)
        brr(n, 2) = it(1)
        brr(n, 3) = "=sum(rc[1]:rc[2])"
        brr(n, 6) = "=sum(rc[1]:rc[2])"
        For Each kk In d(k).keys
            For Each kkk In d(k)(kk).keys
                x = Application.Match(kkk & "*" & kk & "*", crr, 0)
                If InStr(kk, "CC") Or InStr(kk, "MM") Then
                    brr(n, x) = brr(n, x) + d(k)(kk)(kkk)
                Else
                    brr(n, x) = d(k)(kk)(kkk)
                End If
            Next
        Next
    Next
    With sht
        .[a4].CurrentRegion.Offset(2).ClearContents
        .[a5].Resize(n, 8) = brr
    End With
    Set d = Nothing
    Beep
End Sub