Search for a Sub-folder on another Network Drive

[igillesp]

Hi!

I had a set of ~50 project folders (format e.g. 12345_Project_Name) which mere migrated to another server, but in the process were moved into different subfolders and in some instances were renamed, so I cant, for example, simply rename hyperlinks from \\drive_a\ to \\drive_b\.

I've pulled together some code to navigate to the new drive (e.g. L:\Active_Projects), after which it should run through a range of project IDs and, if found, return the network path to the active cell as a hyperlink.

It works (slowly; ~2 mins) on a single cell, but crashes Excel if I try a range of more than about three cells. Not sure if it is the code or the number of subfolders on the new drive.

Grateful for any advice on how to improve or alternative approaches which may work.

Thanks!

Sub aa_Test()

Dim myRoot As String

    myRoot = BrowseFolder

    Application.ScreenUpdating = False

    Call Recurse(myRoot)
    
    Application.ScreenUpdating = True
    MsgBox "Done!"

End Sub

Function Recurse(sPath As String) As String

    Dim FSO As New FileSystemObject
    Dim myFolder As folder
    Dim mySubFolder As folder
    Dim myFile As File

    Set myFolder = FSO.GetFolder(sPath)

    For Each xCell In Selection

        For Each mySubFolder In myFolder.subfolders
                If InStr(mySubFolder.Name, xCell.Value) > 0 Then
                
                     Dim Drive As String
                     Drive = Left(mySubFolder.Path, 2)

                    ActiveSheet.Hyperlinks.Add Anchor:=xCell, _
                    Address:=Replace(mySubFolder.Path, Drive, GetNetworkPath(Drive))
                    
                    xCell.Offset(0, 1).Value = Now()
                    
                    Exit For
                End If
            
            Recurse = Recurse(mySubFolder.Path)
        Next
    Next
    
End Function

Public Function BrowseFolder()
    Dim FldrPicker As FileDialog
    Dim myPath As String
        
    'Browse Folder Path
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    
      With FldrPicker
        .Title = "Browse Root Folder Path"
        .AllowMultiSelect = False
          If .Show <> -1 Then Exit Function
          myPath = .SelectedItems(1)
      End With
 
      BrowseFolder = myPath
      If myPath = vbNullString Then Exit Function

End Function

Function GetNetworkPath(ByVal DriveName As String) As String

    Dim objNtWork  As Object
    Dim objDrives  As Object
    Dim lngLoop    As Long

    Set objNtWork = CreateObject("WScript.Network")
    Set objDrives = objNtWork.enumnetworkdrives

    For lngLoop = 0 To objDrives.Count - 1 Step 2
        If UCase(objDrives.Item(lngLoop)) = UCase(DriveName) Then
            GetNetworkPath = objDrives.Item(lngLoop + 1)
            Exit For
        End If
    Next

End Function

 

[John_w]

It works (slowly; ~2 mins) on a single cell, but crashes Excel if I try a range of more than about three cells. Not sure if it is the code or the number of subfolders on the new drive.

Probably because your Recurse routine is looping through the cells with the following loop:

For Each xCell In Selection

and when it calls itself it starts again with the first cell in the Selection.

Move the above loop and the code which creates the hyperlink and writes to xCell.Offset(0,1) to the main procedure and change Recurse to return the path of the found file.

However even with these changes the recursive FileSystemObject search method would still be slow because it repeats the search of the Windows file system for every cell in the Selection.

A faster method would be to create an array of all the files in a folder (e.g. L:\Active_Projects) and its subfolders and search that array. You could do that with a recursive FileSystemObject procedure, which is relatively slow. A much faster method would be to create the array from the output of a DOS DIR command - see this code:

VBA Drive Directory

Hi Guys, Need a code which list the full file path of all folders, sub folders and files held on a shared drive and writes the results within excel. So basically everything stored on the drive. example: Column A C:\new folder\test.doc C:\new folder\test2.xls etc. There are a lot of files on...

www.mrexcel.com

In that code you would search the dirLines array.

 

[igillesp]

Probably because your Recurse routine is looping through the cells with the following loop:


and when it calls itself it starts again with the first cell in the Selection.

Move the above loop and the code which creates the hyperlink and writes to xCell.Offset(0,1) to the main procedure and change Recurse to return the path of the found file.

However even with these changes the recursive FileSystemObject search method would still be slow because it repeats the search of the Windows file system for every cell in the Selection.

A faster method would be to create an array of all the files in a folder (e.g. L:\Active_Projects) and its subfolders and search that array. You could do that with a recursive FileSystemObject procedure, which is relatively slow. A much faster method would be to create the array from the output of a DOS DIR command - see this code:

VBA Drive Directory

Hi Guys, Need a code which list the full file path of all folders, sub folders and files held on a shared drive and writes the results within excel. So basically everything stored on the drive. example: Column A C:\new folder\test.doc C:\new folder\test2.xls etc. There are a lot of files on...

www.mrexcel.com

In that code you would search the dirLines array.

Thanks for your advice John_w!

I ended up with the code below.

To your point about speed, it takes about a minute a search, which easily meets my needs, but I'll investigate the array approach next.

Iain

Sub FindFolders()
    Dim aList As String, aFolder As String, myFold As String, Drive As String
    aFolder = BrowseFolder

For Each xcell In Selection

    myFold = xcell.Value

    aList = Recurse(aFolder, myFold)
    If aList <> "" Then
        ActiveSheet.Hyperlinks.Add Anchor:=xcell, Address:=aList
        xcell.Offset(0, 1).Value = Now()
    End If
    
Next

End Sub

Function Recurse(sPath As String, myFold As String) As String

Dim FSO As New FileSystemObject, myFolder As folder, mySubFolder As folder
Set myFolder = FSO.GetFolder(sPath)

    For Each mySubFolder In myFolder.subfolders
        If InStr(mySubFolder.Name, myFold) > 0 Then
            Recurse = mySubFolder
            Exit Function
        End If
        
        Recurse = Recurse(mySubFolder.Path, myFold)
    
    Next
End Function