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

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

'2014-12-17

'http://www./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 In Fso.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./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

    With Sheet1.[a1].Validation

        .Delete

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

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

    End With

End Sub