'19，多工作簿提取指定数据（FileSystemObject）by:一念

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

Sub GetData()

    Dim Fso As Object, Fld

    Dim rng As Range, Arr

    Set Fso = CreateObject("Scripting.FileSystemObject")

    For Each Fld In Fso.getfolder(ThisWorkbook.PATH & "\").SubFolders

        Arr = GetObject(Fld.PATH & "\备用整理.xls").Sheets("明细"). _

        Range("W3:X51")

        GetObject(Fld.PATH & "\备用整理.xls").Close

        Set rng = Rows(1).Find(Fld.Name, , , 1)(3)   '第3行

        rng.Resize(UBound(Arr), 2) = Arr

    Next

End Sub

'模版0827.xls

'http://club.excelhome.net/forum.php?mod=viewthread&tid= _

911279&page=1#pid6248314

Sub GetData()

    Dim Fso As Object, Fld, nm, col%, Arr, Myc%, r%, Arr1()

    Dim wb As Workbook, Sht As Worksheet

    Application.ScreenUpdating = False

    Set Fso = CreateObject("Scripting.FileSystemObject")

    Set Fld = Fso.getfolder(ThisWorkbook.PATH & "\").SubFolders("1")

    For Each nm In Fld.Files   '先找出应该文件夹里面的文件

        r = r + 1

        ReDim Preserve Arr1(1 To r)

        Arr1(r) = nm.Name

    Next

    For i = 1 To r

        Set wb = Workbooks.Add

        Set Sht = wb.Worksheets(1)

        For Each Fld In Fso.getfolder(ThisWorkbook.PATH & "\").SubFolders

            Arr = GetObject(Fld.PATH & "\" & Arr1(i)).Sheets("Sheet1"). _

            Range("A1").CurrentRegion

            GetObject(Fld.PATH & "\" & Arr1(i)).Close Myc = [iv1]. _

            End(xlToLeft).Column

            If Myc <> 1 Then

                col = Myc + 1

            Else

                col = 1

                Sht.Cells(1, col).Resize(UBound(Arr), UBound(Arr, 2)) = Arr

        Next

        wb.SaveAs ThisWorkbook.PATH & "\" & Arr1(i)

        wb.Close

    Next

    Application.ScreenUpdating = True

End Sub