VBA Add Hyperlink to Folder If Cell Contents Match Folder Name

[Peteor]

I have a directory of Excel files which are present in several sub-folders. I also have Information in column A of my Worksheet 1 (which will be the active sheet) and will be an exact match to the folder name. I would like to design a macro which searches all of the folders in a specified starting location, until a folder name matches the contents of the active cell (starting with A2). When a match is found, it adds a hyperlink to the information in the active cell to the matching folder. It would then activate the next cell, and do it again until it has completed all of the used cells in column A. I know there are lots of threads about this, but I couldn't find much about my specific situation. Would anyone have any ideas on a good starting point? I have designed macros, and know the code. I do not know how to reference Folders rather than files.

 

[Peteor]

Working through this I have the following:

Sub Add_Hyperlinks()


Worksheets(1).Activate


Dim rng As Range
Dim cell As Range
Dim Cell_Contents As String
Dim Starting_Location As String


Starting_Location = "C:\Sandbox"


Set rng = Range("A2:A")


For Each cell In rng


Cell_Contents = ActiveCell.Value

'I am looking to find a folder in C:\Sandbox which has the same name as variable Cell_Contents. When a match is found...Do things. Anyone have some input?


Next cell




End Sub

 

[John_w]

How many levels of subfolder in C:\Sandbox\ should the code search? If only 1 level then the Dir function could be used.

 

[Peteor]

It would usually be 3 levels deep. I thought about the DIR, but wasn't sure how to make it work.

 

[John_w]

In that case, try this macro which uses the DOS DIR command, instead of the VBA Dir function.

Public Sub Create_Hyperlinks_To_Folders()

    Dim mainFolderPath As String
    Dim folderCell As Range, folderCells As Range
    Dim folders As Variant
    Dim foundFolder As String, i As Long
    
    mainFolderPath = "C:\Sandbox\"
    
    If Right(mainFolderPath, 1) <> "\" Then mainFolderPath = mainFolderPath & "\"
    
    folders = Get_Subfolders_In_Folder(mainFolderPath)
    
    With ActiveSheet
        Set folderCells = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    
    For Each folderCell In folderCells
        foundFolder = ""
        i = 0
        While i < UBound(folders) And foundFolder = ""
            If InStr(1, folders(i), "\" & folderCell.Value, vbTextCompare) Then foundFolder = folders(i)
            i = i + 1
        Wend
        If foundFolder <> "" Then
            folderCell.Hyperlinks.Add Anchor:=folderCell, Address:=foundFolder, TextToDisplay:=folderCell.Value
        Else
            folderCell.Hyperlinks.Delete
       End If
    Next
    
End Sub


Private Function Get_Subfolders_In_Folder(folderPath As String) As Variant

    Dim WSh As Object
    Dim tempFile As String
    Dim command As String
    Dim FSO As Object, ts As Object
    Dim folderFiles As Variant
    
    Set WSh = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")
        
    tempFile = Environ$("temp") & "\temp.txt"
        
    command = "cmd /c DIR /AD /B /S " & Q(folderPath) & " > " & Q(tempFile)
    WSh.Run command, 0, True

    Set ts = FSO.OpenTextFile(tempFile)
    If Not ts.AtEndOfStream Then
        folderFiles = Split(ts.ReadAll, vbCrLf)
    End If
    ts.Close
    Kill tempFile
    
    Get_Subfolders_In_Folder = folderFiles
    
End Function

Private Function Q(text As String)
    Q = Chr(34) & text & Chr(34)
End Function