12，多工作表汇总（字典）

'12，多工作表汇总（字典）

'1231228.xls

'http://club./thread-518738-1-1.html

模块1:

Public m%, k1

    Private Sub Workbook_Open()

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

        Set d = CreateObject("Scripting.Dictionary")

        With Sheet3

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

            Arr = .Range("a2:e" & Myr)

            For i = 1 To UBound(Arr)

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

            Next

            k = d.keys

            With Sheet1.[b1].Validation

                .Delete

                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _

                Operator:=xlBetween, Formula1:=Join(d.keys, ",")

            End With

            d.RemoveAll

            Set d = CreateObject("Scripting.Dictionary")

            For i = 1 To UBound(Arr)

                d(Arr(i, 4)) = ""

            Next

            m = d.Count

            k1 = d.keys

        End With

    End Sub

    Private Sub Worksheet_Change(ByVal Target As Range)

        If Target.Count > 1 Then Exit Sub

        If Target.Address <> "$B$1" Then Exit Sub

        Dim d, k, t, Arr, i&, Myr&, x, yf, j&, Arr1

        Dim ii&, lj, zb, ljs, cp, j1%, y, jj%

        Set d = CreateObject("Scripting.Dictionary")

        yf = Target.Value

        With Sheet2

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

            Arr = .Range("a2:e" & Myr)

            For i = 1 To UBound(Arr)

                x = Arr(i, 1) & "|" & Arr(i, 4)

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

            Next

            k = d.keys

            t = d.items

            ReDim Arr1(1 To m, 1 To 7)

            For j = 0 To UBound(k1)

                For j1 = 0 To UBound(k)

                    y = Val(Split(k(j1), "|")(0))

                    cp = Split(k(j1), "|")(1)

                    If cp = k1(j) And y = yf Then Arr1(j + 1, 1) = k1(j)

                        Arr1(j + 1, 3) = t(j1) '本月发货

                    End If

                    If cp = k1(j) And y < yf + 1 Then

                        lj = lj + t(j1)  '累计发货

                    End If

                Next

                Arr1(j + 1, 6) = lj '累计发货

                lj = 0

            Next

        End With

        d.RemoveAll

        Set d = CreateObject("Scripting.Dictionary")

        With Sheet3

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

            Arr = .Range("a2:e" & Myr)

            For i = 1 To UBound(Arr)

                x = Arr(i, 1) & "|" & Arr(i, 4)

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

            Next

            k = d.keys

            t = d.items

            For j = 0 To UBound(k1)

                For j1 = 0 To UBound(k)

                y = Val(Split(k(j1), "|")(0))

                cp = Split(k(j1), "|")(1)

                If cp = k1(j) And y = yf Then

                    Arr1(j + 1, 2) = t(j1) '本月指标

                        For ii = 1 To UBound(k) + 1

                            zb = zb + t(ii - 1) '本年指标

                        Next

                    Arr1(j + 1, 5) = zb '本年指标

                    zb = 0

                    Exit For

                End If

                Next

            Next

        End With

        d.RemoveAll

        Set d = CreateObject("Scripting.Dictionary")

        With Sheet4

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

            Arr = .Range("a2:e" & Myr)

            For i = 1 To UBound(Arr)

                x = Arr(i, 1) & "|" & Arr(i, 4)

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

            Next

                k = d.keys

                t = d.items

            For j = 0 To UBound(k1)

                For j1 = 0 To UBound(k)

                    y = Val(Split(k(j1), "|")(0))

                    cp = Split(k(j1), "|")(1)

                    If cp = k1(j) And y = yf Then

                        Arr1(j + 1, 4) = t(j1) '上年发货

                    End If

                    If cp = k1(j) And y < yf + 1 Then

                        ljs = ljs + t(j1)             '累计发货

                    End If

                Next

                Arr1(j + 1, 7) = ljs '累计发货

                ljs = 0

            Next

        End With

        Sheet1.[c4].Resize(UBound(Arr1), 7).ClearContents

        Sheet1.[c4].Resize(UBound(Arr1), 7) = Arr1

    End Sub