Search for a Sub-folder on another Network Drive

igillesp

New Member
Joined
Jun 1, 2010
Messages
6
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!

VBA Code:
Sub aa_Test()

Dim myRoot As String

    myRoot = BrowseFolder

    Application.ScreenUpdating = False

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

End Sub

VBA Code:
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

VBA Code:
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

VBA Code:
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
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,751
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:

In that code you would search the dirLines array.
 

igillesp

New Member
Joined
Jun 1, 2010
Messages
6
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:

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

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,129,479
Messages
5,636,574
Members
416,925
Latest member
malamutus

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top