7，多工作簿多工作表查询汇总去重复值（字典数组）

'7，多工作簿多工作表查询汇总去重复值（字典数组）

'http://club./viewthread.php?tid=485193&pid=3181286&page=1

‘&extra=page%3D1

'详细记录.xls

'3个工作簿需要都打开

Sub xxjl()

    Dim Sht1 As Worksheet, Sht As Worksheet

    Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook

    Dim i&, Myr2&, Arr2, Myr&, Arr, Myr1&, xm$, yl$

Application.ScreenUpdating = False

    Set wb1 = ActiveWorkbook

    Set wb2 = Workbooks("购进")

    Set wb3 = Workbooks("配料")

    wb2.Activate

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

    Arr2 = Range("a2:d" & Myr2)

    wb3.Activate

    For i = 1 To UBound(Arr2)

        wb3.Activate

        xm = Arr2(i, 2)

        For Each Sht In Sheets

            If Sht.Name = xm Then

                Sht.Activate

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

                Arr = Range("a1:b" & Myr)

                For j = 1 To UBound(Arr)

                    yl = Arr(j, 1)

                    wb1.Activate

                    For Each Sht1 In Sheets

                        If Sht1.Name = yl Then

                            Sht1.Activate

                            Myr1 = [a65536].End(xlUp).Row + 1

                            Cells(Myr1, 1) = Arr2(i, 1)

                            Cells(Myr1, 3) = Arr2(i, 3)

                            Cells(Myr1, 2) = Arr2(i, 4) * Arr(j, 2)

                            Exit For

                        End If

                    Next

                Next j

                GoTo 100

            End If

        Next

100:

    Next i

    Call qccf

Application.ScreenUpdating = True

End Sub

Sub qccf()

    Dim Sht As Worksheet, Myr&, Arr, i&, x

    Dim d, k, t, Arr1, j&

Application.ScreenUpdating = False

    For Each Sht In Sheets

        Sht.Activate

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

        Arr = Range("a2:c" & Myr)

        Set d = CreateObject("Scripting.Dictionary")

        If Myr < 3 Then GoTo 100

        For i = 1 To UBound(Arr)

            x = Arr(i, 1) & "," & Arr(i, 3)

            If Not d.exists(x) Then

                d(x) = Arr(i, 2)

            Else

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

            End If

        Next

        k = d.keys

        t = d.items

        ReDim Arr1(1 To UBound(k) + 1, 1 To 3)

        For j = 0 To UBound(k)

            Arr1(j + 1, 1) = Split(k(j), ",")(0)

            Arr1(j + 1, 3) = Split(k(j), ",")(1)

            Arr1(j + 1, 2) = t(j)

        Next j

        Range("a2:c" & Myr).ClearContents

        [a2].Resize(UBound(Arr1), 3) = Arr1

100:

        Set d = Nothing

    Next

Application.ScreenUpdating = True

End Sub