'30,，多工作簿匯總(GetObject)

'2014-10-1

'http://club./thread-1155861-1-1.html?jdfwkey=0zauo3

Dim d, d1

Sub lqxs()

    Dim myPath$, myName$, Arr1

    Dim i&, x$, k, t, Arr

    Set d = CreateObject("Scripting.Dictionary")

    Set d1 = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False

    Sheet1.Activate

    [a2:h5000].ClearContents

    [a2:h5000].Borders.LineStyle = xlNone

    myPath = ThisWorkbook.PATH & "\"

    myName = "訂單列表.xlsx"

    With GetObject(myPath & myName)

        Arr1 = .Sheets(1).Range("A1").CurrentRegion

        For i = 2 To UBound(Arr1)

            x = Arr1(i, 2) & "," & Arr1(i, 3)

            d(x) = d(x) + Arr1(i, 4)

        Next

        .Close False

    End With

    k = d.keys: t = d.items

    [b2].Resize(d.Count) = Application.Transpose(k)

    [f2].Resize(d.Count) = Application.Transpose(t)

    Application.DisplayAlerts = False

    [b2].Resize(d.Count).TextToColumns DataType:=xlDelimited, Comma:=True, FieldInfo _

    :=Array(Array(1, 2), Array(2, 2))

    [a2] = 1: [a3] = 2: [a2:a3].AutoFill [a2].Resize(d.Count)

    [a1].CurrentRegion.Borders.LineStyle = 1

    Arr = Range("A1").CurrentRegion

    For i = 2 To UBound(Arr)

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

        d1(x) = i

    Next

    Call hz

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

End Sub

Sub hz()

    Dim myPath$, myName$, Arr1, nm, col, aa, x$

    col = Array(4, 5, 7, 8)

    c = Array(Array(3, 4, 5), Array(1, 2, 3), Array(2, 3, 4), Array(2, 3, 4))

    nm = Array("2013發(fā)貨匯總", "期初庫存", "發(fā)貨列表", "生產(chǎn)下單")

    myPath = ThisWorkbook.PATH & "\"

    For i = 0 To UBound(nm)

        myName = Dir(myPath & nm(i) & ".xlsx")

        With GetObject(myPath & myName)

            Arr1 = .Sheets(1).Range("A1").CurrentRegion

            aa = c(i)

            For j = 2 To UBound(Arr1)

                x = Arr1(j, aa(0)) & "," & Arr1(j, aa(1))

                If d1.exists(x) Then

                    Cells(d1(x), col(i)) = Cells(d1(x), col(i)) + Arr1(j, aa(2))

                End If

            Next

            .Close False

        End With

    Next

End Sub

'2013-3-29

Sub lqxs()

    Dim Arr, myPath$, myName$, Arr1, Myr&

    Application.ScreenUpdating = False

    Sheet1.Activate

    [a2:bz5000].ClearContents

    myPath = ThisWorkbook.PATH & "\提取工作簿里的工作表\"

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

    Do While myName <> ""

        With GetObject(myPath & myName)

            Arr1 = .Sheets(1).Range("A1").CurrentRegion

            Arr = .Sheets(1).Range("A2").Resize(UBound(Arr1) - 1, UBound(Arr1, 2))

            .Close False

        End With

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

        Cells(Myr, 1).Resize(UBound(Arr), UBound(Arr, 2)) = Arr

        myName = Dir

    Loop

    Application.ScreenUpdating = True

End Sub

'2012-10-27 多工作簿多工作表匯總

'http://club./forum.php?mod=viewthread&tid=936361&page=1#pid6418468

Sub lqxs()

    Dim Arr, myPath$, myName$, wb As Workbook, sh As Worksheet

    Dim funm$, i&, d(2), nm, m&

    Application.ScreenUpdating = False

    For i = 0 To 2

        Set d(i) = CreateObject("Scripting.Dictionary")

    Next

    Set wb = ThisWorkbook

    funm = "匯總.xlsm"

    nm = Array("大班", "中班", "小班")

    myPath = ThisWorkbook.PATH & "\"

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

    Do While myName <> ""

        If myName <> funm Then

            With GetObject(myPath & myName)

                For Each sh In .Sheets

                    Arr = sh.Range("b5").CurrentRegion

                    m = Application.Match(sh.Name, nm, 0) - 1

                    For i = 1 To UBound(Arr)

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

                    Next

                Next

                .Close False

            End With

        End If

        myName = Dir

    Loop

    For i = 0 To 2

        Sheets(nm(i)).[b5].Resize(100, 1).ClearContents

        Sheets(nm(i)).[b5].Resize(d(i).Count, 1) = Application.Transpose(d(i).keys)

    Next

    Application.ScreenUpdating = True

End Sub

'2012-12-31

'http://club./thread-964827-1-2.html

Public cs$, mm&

Sub lqxs()

    Dim myPath$, myName$, Arr1

    Dim i&, Brr, nm$

    Application.ScreenUpdating = False

    Cells(mm, 2).Select

    nm = Selection(1, 1).Value

    Cells(mm, 4).Select

    myPath = ThisWorkbook.PATH & "\"

    myName = cs & ".xls"

    With GetObject(myPath & myName)

        Arr1 = .Sheets(1).Range("A1").CurrentRegion

        Brr = .Sheets(1).Range("b1").Resize(UBound(Arr1), 12)

        .Close False

    End With

    For i = 3 To UBound(Arr1)

        If Arr1(i, 1) = nm Then

            Cells(mm, 4).Resize(1, 12) = Application.Index(Brr, i, 0)

            Exit Sub

        End If

    Next

    Application.ScreenUpdating = True

End Sub

'2012-9-21

'http://club./forum-2-1.html

Sub lqxs()

    Dim Arr, myPath$, myName$, wb As Workbook, Arr1

    Dim m&, funm$, col%, i&, Brr, d, n&

    Application.ScreenUpdating = False

    Set d = CreateObject("Scripting.Dictionary")

    Set wb = ThisWorkbook

    funm = "huizong.xlsm"

    Sheet1.Activate

    Arr = [b2].CurrentRegion

    For i = 2 To UBound(Arr)

        d(Arr(i, 1)) = i

    Next

    col = 2

    myPath = ThisWorkbook.PATH & "\分表\"

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

    Do While myName <> "" And myName <> funm

        With GetObject(myPath & myName)

            Arr1 = .Sheets(1).Range("A1").CurrentRegion

            .Close False

        End With

        ReDim Brr(1 To UBound(Arr))

        Brr(1) = Split(Mid(myName, InStrRev(myName, "\") + 1), ".")(0)

        For i = 3 To UBound(Arr1)

            If d.exists(Arr1(i, 1)) Then

                n = d(Arr1(i, 1))

                Brr(n) = Arr1(i, 2)

            End If

        Next

        col = col + 1

        Cells(2, col).Resize(UBound(Arr), 1) = Application.Transpose(Brr)

        Erase Brr

        myName = Dir

    Loop

    Application.ScreenUpdating = True

End Sub

'2012-9-23

'http://club./forum.php?mod=viewthread&tid=924305&page=1#pid6330929

 

 

Sub lqxs()

'批量導入指定文件的數(shù)據(jù)

    Dim myFs As FileSearch, myfile

    Dim myPath As String, FileName$, ma&, mc&

    Dim i As Long, n As Long, nn&, aa$, nm$, nm1$

    Dim Sht1 As Worksheet, sh As Worksheet

    Application.ScreenUpdating = False

    nm = ThisWorkbook.Name

    nm = Left(nm, Len(nm) - 4)

    Set Sht1 = ActiveSheet

    Sht1.[a2:m5000] = ""

    Set myFs = Application.FileSearch

    myPath = ThisWorkbook.PATH & "\績效管理"   '指定的子文件夾內(nèi)搜索

    With myFs

        .NewSearch

        .LookIn = myPath

        .FileType = msoFileTypeNoteItem

        .FileName = "*.xls"

        .SearchSubFolders = True

        If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

            ReDim myfile(1 To n) As String

            For i = 1 To n

                myfile(i) = .FoundFiles(i)

                FileName = myfile(i)

                nm1 = Split(Mid(FileName, InStrRev(FileName, "\") + 1), ".")(0)

                If nm1 <> nm Then

                    Dim wb As Workbook

                    Set wb = Workbooks.Open(myfile(i))

                    aRow = wb.Sheets(1).Range("a5000").End(xlUp).Row

                    tRow = Sht1.Range("a5000").End(xlUp).Row + 1

                    wb.Sheets(1).Range("a3:m" & aRow).Copy Sht1.Range("a" & tRow)

                    wb.Close False

                End If

                Set wb = Nothing

            Next

        Else

            MsgBox "該文件夾里沒有任何文件"

        End If

    End With

    [a1].Select

    Set myFs = Nothing

    Application.ScreenUpdating = True

End Sub

'2013-9-1

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

Sub lqxs()

    Dim Arr, myPath$, myName$, Arr1, Myr&, d, j&

    Dim m&, col, nm$, n&

    Set d = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False

    nm = ThisWorkbook.Name

    Sheet1.Activate

    [b3:bl5000].ClearContents

    Arr = [a1].CurrentRegion

    For i = 3 To UBound(Arr)

        d(Arr(i, 1)) = i

    Next

    myPath = ThisWorkbook.PATH & "\"

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

    Do While myName <> ""

        If myName <> nm Then

            col = Split(Split(myName, ".")(0), "-")(2) + 1

            With GetObject(myPath & myName)

                Arr1 = .Sheets(1).Range("A1").CurrentRegion

                For j = 1 To UBound(Arr1, 2) Step 4

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

                        m = d(Arr1(1, j))

                        Cells(m, col) = Arr1(1, j + 1)

                        Cells(m, col + 32) = Arr1(1, j + 3)

                        For i = 2 To UBound(Arr1) Step 22

                            If Arr1(i, j) <> "" Then

                                If d.exists(Arr1(i, j)) Then n = d(Arr1(i, j))

                                Cells(n, col) = Cells(n, col) + Arr1(i + 21, j + 1)

                                Cells(n, col + 32) = Cells(n, col + 32) + Arr1(i + 21, j + 3)

                                End If

                            Else

                                Exit For

                            End If

                        Next

                    End If

                Next

                .Close False

            End With

        End If

        myName = Dir

    Loop

    Application.ScreenUpdating = True

    MsgBox "OK"

End Sub