Help Replacing FileSearch with FileSystemObject

[bpacct]

Let me start off with I know very little about VBA, but I've been tasked at work to learn more. I've bought a few books, so I'm in the process but still not enough to fully understand in depth code.

I have an upload file that when a user presses the button, a menu comes up for them to select a folder, and then all files in that folder that being with a 6-digit number are copied into the original upload file. Well this process used FileSearch, so when the user upgraded Office, the import no longer worked. In researching, I read that it is best to replace the no longer available FileSearch with a FileSystemObject; however, I am still getting an error and not sure what I've done incorrect.


This is the import code that I think is the only thing that needs corrections/causing errors:

'Imports Worksheets from the passed folder path, matching the passed pattern.
Private Sub Import_Worksheets(FilePath As String, sPattern As String)
Dim FS As Object
Dim FileSpec As String
Dim Index As Integer
Dim sPath As String
Dim tWorkbook As Workbook
Dim tWorksheet As Worksheet
Dim bFoundDepts As Boolean


    On Error GoTo ErrorHandler:


    'Toggle off screen refreshing and application level events
    StealthMode True


    'Specify path and file spec
    FileSpec = "*.xls"


    'Create a FileSearch object
    Set FS = CreateObject("Scripting.FileSystemObject")
    With FS
        .LookIn = FilePath
        .Filename = FileSpec
        .Execute




        'Exit if no files are found
        If FS.FoundFiles.Count = 0 Then
            MsgBox "No files were found", vbOKOnly, "No Files"
            Exit Sub
        End If




        'Loop through the files and process them
        For Index = 1 To .FoundFiles.Count
            If Get_FileName(FS.FoundFiles.Item(Index)) <> ThisWorkbook.Name Then
                Workbooks.Open FS.FoundFiles.Item(Index)
                For Each tWorkbook In Workbooks
                    If tWorkbook.path = FilePath Then
                        'Copy the department sheet to ThisWorkbook
                        For Each tWorksheet In tWorkbook.Worksheets
                            If IsLike(tWorksheet.Name, sPattern) = True Then
                                'Copy the worksheet with a number for the name to ThisWorkbook
                                tWorksheet.Copy Before:=ThisWorkbook.Sheets(1)
                                
                                'We found at least one department in the folder
                                bFoundDepts = True
                            End If
                        Next tWorksheet
    
                        tWorkbook.Close
                    End If
                 Next tWorkbook
            End If
        Next Index
    End With


    'Notify the user that the departments were successfully imported
    If bFoundDepts = True Then
        MsgBox "Departments Imported", vbOKOnly, "Import Departments"
    Else
        MsgBox "In the folder you selected, no department sheets could be found for any workbook.", vbOKOnly, "No Departments Found"
    End If


    'Toggle on screen refreshing and application level events
    StealthMode True


    Exit Sub


ErrorHandler:
MsgBox Err.Description
Err.Clear
End Sub

Here is some other code in the same worksheet that may be affecting this one. I'm not entirely sure at the moment.

Option Explicit


Private Type BROWSEINFO ' used by the function GetFolderName
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type


Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer


On Error GoTo ErrorHandler:


    bInfo.pidlRoot = 0& ' Root folder = Desktop
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
        ' the dialog title
    Else
        bInfo.lpszTitle = Msg ' the dialog title
    End If
    bInfo.ulFlags = &H1 ' Type of directory to return
    X = SHBrowseForFolder(bInfo) ' display the dialog
    ' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetFolderName = Left(path, pos - 1)
    Else
        GetFolderName = ""
    End If


    Exit Function


ErrorHandler:
MsgBox Err.Description
Err.Clear
End Function




Private Function Get_Folder() As String
Dim FolderName As String


On Error GoTo ErrorHandler:


    FolderName = GetFolderName("Select a folder containing Excel workbooks with Department tabs, and click the OK button below.")
    If FolderName <> "" Then
        Get_Folder = FolderName
    End If


    Exit Function


ErrorHandler:
MsgBox Err.Description
Err.Clear
End Function


Private Function Get_FileName(sPath As String) As String
On Error GoTo ErrorHandler:
    Get_FileName = Split(sPath, "\")(UBound(Split(sPath, "\")))
    
    Exit Function


ErrorHandler:
MsgBox Err.Description
Err.Clear
End Function

I really wish I could figure this out better myself, but until I actually learn VB, I'm stuck.
I will say, I had tried adding a Dir function instead of the FileSystemObject which ran the code with no errors, but it didn't find any files that I know exist.

 

[John_w]

replace the no longer available FileSearch with a FileSystemObject; however, I am still getting an error and not sure what I've done incorrect.

    'Create a FileSearch object
    Set FS = CreateObject("Scripting.FileSystemObject")
    With FS
        .LookIn = FilePath
        .Filename = FileSpec
        .Execute




        'Exit if no files are found
        If FS.FoundFiles.Count = 0 Then

You can't just replace Application.FileSearch with a FileSystemObject as shown above because these properties and methods don't exist in FSO.

If you don't need to search subfolders of the main folder then the VBA Dir function is all you need. Here's the basic code for a Dir function loop:

Sub Dir_Demo()

    Dim folderPath As String
    Dim file As String
    Dim wb As Workbook
    
    folderPath = "C:\Path\To\Folder\"
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    file = Dir(folderPath & "*.xls")
    While file <> ""
        If file <> ThisWorkbook.Name Then
            MsgBox "Opening " & folderPath & file
            Workbooks.Open folderPath & file
            Set wb = ActiveWorkbook
            wb.Close False
        End If
        file = Dir
    Wend
    
End Sub

See if you can modify your Sub Import_Worksheets to use the same loop structure.

 

[bpacct]

Thanks for that advice. I thought in my searching I saw somewhere that had similar properties.


I've updated my code with the Dir function, and it is running again; however, it is telling me that no sheets were found in the workbook. That's the same issue I had the first time I tried using a Dir function.

 

[John_w]

Please post your complete code if it isn't working.

 

[bpacct]

The user selects the file path where the workbooks are saved; however, even when I set the path in the code, I still received the message that no sheet was found.

'Imports Worksheets from the passed folder path, matching the passed pattern.
Private Sub Import_Worksheets(FilePath As String, sPattern As String)
Dim FS As Object
Dim FileSpec As String
Dim Index As Integer
Dim sPath As String
Dim tWorkbook As Workbook
Dim tWorksheet As Worksheet
Dim bFoundDepts As Boolean


    On Error GoTo ErrorHandler:


    'Toggle off screen refreshing and application level events
    StealthMode True
    
    FileSpec = Dir(FilePath & "*.xls")
    While FileSpec <> ""
        If FileSpec <> ThisWorkbook.Name Then
            MsgBox "Opening " & FilePath & FileSpec
            Workbooks.Open FilePath & FileSpec
            Set tWorkbook = ActiveWorkbook
            tWorkbook.Close False
        End If
        FileSpec = Dir
      


        'Exit if no files are found
        If FS.FoundFiles.Count = 0 Then
            MsgBox "No files were found", vbOKOnly, "No Files"
            Exit Sub
        End If




        'Loop through the files and process them
        For Index = 1 To FS.FoundFiles.Count
            If Get_FileName(FS.FoundFiles.Item(Index)) <> ThisWorkbook.Name Then
                Workbooks.Open FS.FoundFiles.Item(Index)
                For Each tWorkbook In Workbooks
                    If tWorkbook.path = FilePath Then
                        'Copy the department sheet to ThisWorkbook
                        For Each tWorksheet In tWorkbook.Worksheets
                            If IsLike(tWorksheet.Name, sPattern) = True Then
                                'Copy the worksheet with a number for the name to ThisWorkbook
                                tWorksheet.Copy Before:=ThisWorkbook.Sheets(1)
                                
                                'We found at least one department in the folder
                                bFoundDepts = True
                            End If
                        Next tWorksheet
    
                        tWorkbook.Close
                    End If
                 Next tWorkbook
            End If
        Next Index
    Wend


    'Notify the user that the departments were successfully imported
    If bFoundDepts = True Then
        MsgBox "Departments Imported", vbOKOnly, "Import Departments"
    Else
        MsgBox "In the folder you selected, no department sheets could be found for any workbook.", vbOKOnly, "No Departments Found"
    End If


    'Toggle on screen refreshing and application level events
    StealthMode True


    Exit Sub


ErrorHandler:
MsgBox Err.Description
Err.Clear
End Sub

 

[John_w]

You're still using the FS object, now undefined, amongst other incorrect coding. If you really want to figure out the problem for yourself, I suggest you put Option Explicit at the top of the module, fix all compilation errors (Debug -> Compile in the VBA editor until there are no compilation errors), delete or comment out the On Error statement and step through the code line by line by pressing the F8 key, examining variables in the Locals window to verify that their values are as expected.

If you're still having trouble I can post a working solution, but if you want to learn VBA it's better to at least have a go yourself first.

 

[bpacct]

I have no doubt there is incorrect coding - this was written by an IT guy about 8 years ago who had no knowledge of Excel really. I was just given the task of correcting it, despite knowing nothing about VB. The most I've done is recorded some macros in Excel and then gone in to edit pieces of that code to flow better, but I did just buy a learners book to actually try and learn more.

I went through and found no compilation errors and I'm not sure if F8 was producing correctly since the parts of the code are all over in random order and frankly, I don't even know what the rest of the process for this file is. I just know the one part causing an error to the user.

 

[snb_]

Sub M_snb()
  c00="G:\OF\"   ' the folder to look in

  for each it in split(createobject("wscript.shell").exec("cmd /c ""Dir " & c00 & "*.xls"" /b").stdout.readall,vbcrlf)
    with getobject(it)
      for each sh in .sheets
        sh.copy  , thisworkbook.sheets(thisworkbook.sheets.count)
      next
      .close false
    end with
  next
End Sub

 

[bpacct]

Thanks for that update. Can you clarify that code any? I can somewhat understand some items, but that doesn't make sense to me at all. Also, a folder won't be defined in the code - there is a separate action where the user selects the folder the files are saved in when he presses the import button.