34，多工作簿多工作表汇总(GetObject)

'34，多工作簿多工作表汇总(GetObject)

'http://club./thread-1113886-1-1.html '结果表.xlsm '2014-4-20

Sub lqxs()

    Dim Arr1, myPath$, myName$, shnm, nm

    Dim j&, i&, d, y&, n&, Arr

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")

    Sheet1.Activate

    Arr1 = [a1].CurrentRegion

    For i = 2 To UBound(Arr1)

        If Arr1(i, 3) = "?" Or Arr1(i, 6) = "?" Or Arr1(i, 9) = "?" Then

            d(Arr1(i, 2)) = i

        End If

    Next

    nm = Array("3.xlsx", "2.xlsx", "1.xlsx")

    shnm = Array("优先1", "次优", "次次优")

    myPath = ThisWorkbook.PATH & "\数据源\"

    For i = 0 To UBound(nm)

        myName = Dir(myPath & nm(i))

        With GetObject(myPath & myName)

            For y = 0 To 2

                Arr = .Sheets(shnm(y)).[a1].CurrentRegion

                For j = 2 To UBound(Arr)

                    If d.exists(Arr(j, 1)) Then

                        n = d(Arr(j, 1))

                        If Arr1(n, 3) = "?" Then Arr1(n, 3) = Arr(j, 3)

                        If Arr1(n, 6) = "?" Then Arr1(n, 6) = Arr(j, 4)

                        If Arr1(n, 9) = "?" Then Arr1(n, 9) = Arr(j, 5)

                        Exit For

                    End If

                Next

            Next

            .Close False

        End With

    Next

    [a1].CurrentRegion = Arr1

    Application.ScreenUpdating = True

End Sub

'2013-5-5

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

Sub lqxs()

    Dim Arr, myPath$, myName$, col%, m&, sh As Worksheet

    Dim j&, i&, d, nm, n&, Brr(1 To 5000, 1 To 20), c%, d1

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")

    Set d1 = CreateObject("Scripting.Dictionary")

    Sheet1.Activate

    [a:h].ClearContents

    myPath = ThisWorkbook.PATH

    aa = InStrRev(myPath, "\")

    myPath = Left(myPath, aa) & "数据源\"

    myName = Dir(myPath & "*.xlsx")

    Do While myName <> ""

        With GetObject(myPath & myName)

            For Each sh In .Sheets

                If InStr(sh.Name, "数据源") Then

                    Arr = sh.[a1].CurrentRegion

                    For j = 1 To UBound(Arr, 2)

                        If Arr(2, j) <> "" Then

                            If Not d.exists(Arr(2, j)) Then c = c + 1: d(Arr(2, j)) = c

                            col = d(Arr(2, j))

                            For i = 3 To UBound(Arr)

                                If Not d1.exists(Arr(i, 2)) Then m = m + 1

                                    d1(Arr(i, 2)) = m

                                    Brr(m, col) = Arr(i, j)

                                Else

                                    m = d1(Arr(i, 2))

                                    Brr(m, col) = Arr(i, j)

                                End If

                            Next

                        End If

                    Next

                End If

            Next

            .Close False

        End With

        myName = Dir

    Loop

    [a1].Resize(1, d.Count) = d.keys

    [a2].Resize(m, d.Count) = Brr

    Application.ScreenUpdating = True

End Sub