Alternative to FileSearch Function (Excel VBA)

[Rudi]

Hi all,

I need help to convert this old FILESEARCH function into an alternative process that will run in Excel 2007. FileSearch was a function that was discontinued in 2007. All I need to do is point code to a folder on my C:\ and it must open each workbook, copy the first sheet into ThisWorkook and close each workbook. (GetData is another macro in the current moduule that will also run...)

I have dug around a bit using Google and the closest I have come to a solution is apparently using this object: Set FSO = CreateObject("Scripting.FileSystemobject") The sample code looked very complex and I got a few debugs in the sample code I tried to edit. So...bottom line... I need your help to create some code that will open, copy sheet and close multiple excel files in a folder i point the code to. Any help will be appreciated. Many TX

Code: Select all

Sub GetWB()
    Dim myDir As String
    Dim myPath As String
    Dim myFileName As Variant
    Dim i As Integer

    myDir = ActiveWorkbook.Path ' current path
    myPath = myDir & "\SurveyFiles" ' files subdir

    With Application.FileSearch
        .NewSearch
        .LookIn = myPath
        .SearchSubFolders = False
        .Filename = ".xls*"

        If .Execute > 0 Then
            For Each myFileName In .FoundFiles
                Workbooks.Open myFileName
                Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
                ActiveWorkbook.Close SaveChanges:=False
                Call GetData
            Next
        End If
    End With
End Sub

[HansV]

You can use the Dir function:

Code: Select all

Sub GetWB()
    Dim myDir As String
    Dim myPath As String
    Dim myFileName As String
    Dim wbk As Workbook

    myDir = ActiveWorkbook.Path ' current path
    myPath = myDir & "\SurveyFiles\" ' files subdir - note the trailing backslash

    myFileName = Dir(myPath & "*.xls*")
    Do While myFileName <> ""
        Set wbk = Workbooks.Open(myPath & myFileName)
        wbk.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
        wbk.Close SaveChanges:=False
        Call GetData
        myFileName = Dir
    Loop
End Sub

[Rudi]

Superb, Awesome, TX!!!

Having given such a great answer... is there any value to the FileSystemObject? or is it just a more complex way of doing the same thing?

TX

[HansV]

Here is a version that uses FileSystemObject. It uses late binding, you don't have to set a reference to Windows Scripting Runtime for the code to work.

Code: Select all

Sub GetWB()
    Dim myDir As String
    Dim myPath As String
    Dim myFileName As Variant
    Dim wbk As Workbook
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim p As Long

    myDir = ActiveWorkbook.Path ' current path
    myPath = myDir & "\SurveyFiles\" ' files subdir
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(myPath)
    For Each fil In fld.Files
        p = InStrRev(fil.Name, ".")
        If LCase(Mid(fil.Name, p + 1, 3)) = "xls" Then
            Set wbk = Workbooks.Open(fil.Path)
            wbk.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
            wbk.Close SaveChanges:=False
            Call GetData
        End If
    Next fil

    Set fil = Nothing
    Set fld = Nothing
    Set fso = Nothing
End Sub