'28，2007版FSO方法搜索文件夹文件

'2014-12-17

'http://www.excelpx.com/thread-336169-1-1.html

Sub lqxs()

    Dim Fso, Folder,myPath$, hz$, sh As Worksheet

    Dim i&, nm1$, Files,File, r%, c%

   Application.ScreenUpdating = False

    Sheet1.Activate

    cwells.ClearContents hz= "xls"

    [a1].Resize(1, 3) =Array("文件夹","工作簿名","工作表名")

    r = 1

    myPath =ThisWorkbook.PATH & "\"

    Set Fso =CreateObject("Scripting.FileSystemObject")

    For Each myfol InFso.getfolder(myPath).SubFolders

       Set Files = myfol.Files

       If Files.Count <> 0 Then

           For Each File In Files

               If InStr(File, hz) Then

                   r = r + 1

                   Cells(r, 1) = myfol.Name

                   nm1 = Mid(File, InStrRev(File, "\") + 1)

                   Cells(r, 2) = nm1: c = 2

                   With GetObject(File)

                       For Each sh In .Sheets

                           c = c + 1

                           Cells(r, c) = sh.Name

                       Next

                       .Close False

                   End With

               End If

           Next

       End If

    Next

    Set Folder =Fso.getfolder(myPath)

    Cells(r + 1, 1) =Folder.Name

    Set Files = Folder.Files

    If Files.Count <>0 Then

       For Each File In Files

           If InStr(File, hz) Then

               r = r + 1

               nm1 = Mid(File, InStrRev(File, "\") + 1)

               Cells(r, 2) = nm1: c = 2

               With GetObject(File)

                   For Each sh In .Sheets

                       c = c + 1

                       Cells(r, c) = sh.Name

                   Next

                   .Close False

               End With

           End If

       Next

    End If

End Sub

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

'2012-6-20

Sub yy()

    Dim Fso, Folder,myPath$, hz$

    Dim i&, nm1$, Files,File, r%, Arr1()

   Application.ScreenUpdating = False

    hz = "txt"

    r = 0

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

    Set Fso =CreateObject("Scripting.FileSystemObject")

    Set Folder =Fso.getfolder(myPath)

    Set Files = Folder.Files

    If Files.Count <>0 Then

       For Each File In Files

           If InStr(File, hz) Then

               r = r + 1

               ReDim Preserve Arr1(1 To r)

               nm1 = Mid(File, InStrRev(File, "\") + 1)

               Arr1(r) = nm1

           End If

       Next

    End If

    WithSheet1.[a1].Validation

        .Delete

       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _

       Operator:=xlBetween, Formula1:=Join(Arr1, ",")

    End With

End Sub