15，多工作簿汇总（FileSearch） by:Long III

'15，多工作簿汇总（FileSearch） by:Long III

Private Sub CommandButton1_Click()

    Dim Twb As Workbook, wb As Workbook

    Dim rng As Range

    Dim s, Myr&

    Application.ScreenUpdating = False

    Set Twb = ThisWorkbook

    Cells.ClearContents '清除当前表的内容

    With Application.FileSearch '查找

        .LookIn = Twb.PATH '范围为此目录下

        .FileName = "*.xls" '查找所有的xls文件

        .Execute msoSortByFileName '执行查找过程，并且将查询结果按文件名排序

        For Each s In .FoundFiles '在每一个查找到的结果里

            If s <> Twb.FullName Then '假如它不是当前工作簿

                Set wb = Workbooks.Open(s) '打开它

                Set rng = Range("a65536").End(xlUp).Offset(1, 0) '设置变量rng为最后一行的下一行

                wb.Sheets(1).UsedRange.Copy rng '复制新打开的工作簿的第一个工作表的已用区域到rng

                Cells(rng.Row, 10) = wb.Name

                wb.Close False ' 不保存就关闭这个打开的工作簿

            End If

        Next

    End With

    Application.ScreenUpdating = True

End Sub