33，多工作表汇总，先赋值给数组

'33，多工作表汇总，先赋值给数组

'2013-2-3

'查询按部门年汇总

Sub lqxs()

    Dim Arr, i&, Sht As Worksheet, mm&, Brr

    Dim d, k, t, j&, y&, d1, k1, t1, m&

    Set d = CreateObject("Scripting.Dictionary")

    Set d1 = CreateObject("Scripting.Dictionary")

    Sheet4.Activate

    [a4:g500].ClearContents

    For Each Sht In Sheets

        If Len(Sht.Name) = 8 And InStr(Sht.Name, "工资") And Sht.Name <> Sheet5.Name Then

            mm = mm + 1

            Arr = Sht.[a1].CurrentRegion

            If mm = 1 Then

                For i = 3 To UBound(Arr)

                    d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","

                Next

                k = d.keys

                t = d.items

                ReDim Brr(1 To d.Count, 1 To 7)

                For i = 0 To UBound(k)

                    t(i) = Left(t(i), Len(t(i)) - 1)

                    Brr(i + 1, 1) = k(i)

                    If InStr(t(i), ",") Then

                        aa = Split(t(i), ",")

                        For j = 0 To UBound(aa)

                            For y = 3 To 8

                                Brr(i + 1, y - 1) = Brr(i + 1, y - 1) + Arr(aa(j), y)

                            Next

                        Next

                    Else

                    End If

                Next

            Else

                For i = 3 To UBound(Arr)

                    d1(Arr(i, 1)) = d1(Arr(i, 1)) & i & ","

                Next

            k1 = d1.keys

            t1 = d1.items

            For i = 0 To UBound(k1)

                m = Application.Match(k1(i), k, 0)

                t1(i) = Left(t1(i), Len(t1(i)) - 1)

                If InStr(t1(i), ",") Then

                    aa = Split(t1(i), ",")

                    For j = 0 To UBound(aa)

                        For y = 3 To 8

                            Brr(m, y - 1) = Brr(m, y - 1) + Arr(aa(j), y)

                        Next

                    Next

                Else

                End If

            Next

            d1.RemoveAll

            End If

        End If

    Next

    [a4].Resize(UBound(Brr), 7) = Brr

End Sub