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

'1231228.xls

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

模块1:

Public m%, k1

    Private SubWorkbook_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 SubWorksheet_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