龙门过客栈 / 多工作簿多工... / 19,多工作簿提取指定数据(FileSystemObj...

分享

   

19,多工作簿提取指定数据(FileSystemObject)by:一念

2017-04-05  龙门过客栈

'19,多工作簿提取指定数据(FileSystemObjectby:一念

'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

    本站是提供个人知识管理的网络存储空间,所有内容均由用户发布,不代表本站观点。请注意甄别内容中的联系方式、诱导购买等信息,谨防诈骗。如发现有害或侵权内容,请点击一键举报。

    0条评论

    发表

    请遵守用户 评论公约

    类似文章 更多
    喜欢该文的人也喜欢 更多

    ×
    ×

    ¥.00

    微信或支付宝扫码支付:

    开通即同意《个图VIP服务协议》

    全部>>