Check and match cell value to folder/subfolder returning a hyperlink.

Hi Nilletnilsson,

The code below may do what you are asking for. It will look for a list of folder names in Column A of the activesheet and then put hyperlinks to those folders in Column C if they exist.

Sub GenerateHyperlinks()

'Define Variables
Dim cDrive As Long
Dim arrDrive() As Variant
Dim LastRow As Long
Dim i, j, k As Long
Dim sDir As String
Dim nPath As String
Dim chkPath As String
Dim wks As Worksheet
Dim cDir As Long

Dim FS As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Dim BaseFolder As Object
Dim subfolder As Object

Dim ChooseFolder As FileDialog
Dim StartFolder As String

'Turn off Events
With Application
   .DisplayAlerts = False
   .EnableEvents = False
   .ScreenUpdating = False
End With

' Set current worksheet to 'wks' variable
Set wks = ActiveSheet
If (wks.Name = "tempDirList") Then
   MsgBox "The activesheet is invalid.  Program will end."
   GoTo 100000
End If
'Check if activesheet has data in Column A
LastRow = Range("A" & Rows.Count).End(xlUp).Row
If (LastRow = 1 And IsEmpty(Range("A1"))) Then
   MsgBox "There are no folders to find.  Program will end."
   GoTo 100000
End If

' Get StartFolder
Set ChooseFolder = Application.FileDialog(msoFileDialogFolderPicker)
With ChooseFolder
    .Title = "Select Starting Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo 100000   'If user canceled
    StartFolder = .SelectedItems(1)
End With

' < BEGIN: Make Temporary sheet to list available drives and folders >
If (Evaluate("ISREF('" & "tempDirList" & "'!A1)")) Then Sheets("tempDirList").Delete
Sheets.Add
ActiveSheet.Name = "tempDirList"
' < END: Make Temporary sheet to list available drives and folders >

' < BEGIN: Populate List of Available Folders/Subfolders >
Range("A1") = StartFolder   'Set first folder to StartFolder
' Put subfolder only in Column B
m = InStrRev(StartFolder, "\")
If (m > 0) Then Range("B1") = Right(StartFolder, Len(StartFolder) - m)
' Populate subfolders
j = 1   'Beginning of new range of folders to check
10 LastRow = Range("A" & Rows.Count).End(xlUp).Row
k = LastRow
On Error Resume Next
For i = j To LastRow
    Set BaseFolder = FS.GetFolder(Cells(i, 1) & "\")
    For Each subfolder In BaseFolder.SubFolders
       If (Err.Number <> 0) Then   'Permissions denied, skip
          Err.Clear
       Else
          k = k + 1
          ' Put full path in column A
          Cells(k, 1) = subfolder
          ' Put last subfolder only in Column B
          m = InStrRev(subfolder, "\")
          Cells(k, 2) = Right(subfolder, Len(subfolder) - m)
          Application.StatusBar = subfolder
       End If
   Next subfolder
20
Next i
Application.StatusBar = ""
On Error GoTo 0
     
If (k > LastRow) Then
   j = LastRow + 1
   GoTo 10  ' Loop through subfolders
End If
Set BaseFolder = Nothing
Set ChooseFolder = Nothing
Columns("A:B").AutoFit
cDir = Range("A" & Rows.Count).End(xlUp).Row

' < BEGIN: Search for matching Directories using values in Column A >
LastRow = wks.Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
For i = 1 To LastRow
   k = WorksheetFunction.Match(wks.Range("A" & i), Range("B1:B" & cDir), 0)
   If (Err.Number <> 0) Then
      Err.Clear
      wks.Range("C" & i) = ""
   Else
      wks.Range("C" & i).Formula = "= Hyperlink(""" & Range("A" & k) & """, A" & i & ")"
   End If
Next i
On Error GoTo 0
wks.Activate
Columns("A:C").AutoFit
Sheets("tempDirList").Delete
' < END: Search for matching Directories using values in Column A >

MsgBox "Process complete."

100000
'Turn on Events
With Application
   .DisplayAlerts = True
   .EnableEvents = True
   .ScreenUpdating = True
End With

End Sub

Hope it helps,

Dan

Hi, I'm trying to test this code, but I can't make it work. I should enter some numbers or letters on Column A and when I hit Enter, it will show a hiperlink on Column C if it exist on my hard drive, Right? Thanks.

Here is my approach. I did not turn off and on the Application items to speed it up as Dan did not nor did I resize columns nor allow user to select the parent folder's path.

Obviously, you need to change "x:\t" to your path.

Sub Main()
  Dim x() As Variant, i As Long, c As Range, cc As Range
  x() = aFFs("x:\t", "/ad")  'Search for folders in x:\t.
  'MsgBox Join(x(), vbLf)
  
  For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
    Set cc = c.Offset(, 2)
    i = IndexP(x(), c.Value2)
    cc.ClearContents
    If i > -1 Then ActiveSheet.Hyperlinks.Add Anchor:=cc, Address:=x(i), TextToDisplay:=CStr(c.Value2)
  Next c
End Sub

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, a() As String, v As Variant
  Dim b() As Variant, i As Long
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    MsgBox myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      s = Left$(myDir, InStrRev(myDir, "\"))
      'add the folder name
      a(i) = s & a(i)
    End If
  Next i
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function

'Return index number of a match to last element of delimited string in an array
Function IndexP(vArray() As Variant, val As Variant, _
  Optional tfCaseSensitive As Boolean = False, Optional delim As String = "\") As Long
  Dim x() As String, i As Long
  For i = LBound(vArray) To UBound(vArray)
    x() = Split(CStr(vArray(i)), delim)
    Select Case True
      Case tfCaseSensitive = True
        If x(UBound(x)) = val Then
          IndexP = i
          Exit Function
        End If
      Case Else
        If LCase(x(UBound(x))) = LCase(val) Then
          IndexP = i
          Exit Function
        End If
    End Select
  Next i
  IndexP = -1
End Function

Ok, now I got Dan's code to work. Yours worked the first time I tried. The second one didn't want to work. Don't know why.
Thank you.

Hi guys,

Just a note on my code, when I initially wrote it, it was checking all drives and subfolders just to see how it went and the "C:\Windows" folder and "C:\Program Files" folders were beating it into submission. I think I was up to 26,000 folders by the time I finally stopped the code and I made the statusbar active just to see if it was still running.

To get isolate the number of folders it checks, I put in the part that lets the user pick the folder to start from. Just be aware that if you pick an entire drive, such as the drive your operating system is on, it could take it an eon to actually get through it simply by the number of folders and subfolders on that drive because it will find them all.

Anyway, I'm glad some people tried it and hoped it provided some assistance.

Thanks,

Dan

And Kenneth your code doesn't seem to work at all for me. It just runs without anything happening.

Did you change the path as I explained? Obviously, it works for me or I would not have posted it.

As Dan said, if you have a large number of files and folders, then some wait time might be needed so that the macro does not out run itself.

Hello,

djbomaha, i can't get your code to run smoothly.
The script loops through the maps multiple times before it completes, when it completes it writes the shortcut "C:xxx\xxx\xx\xxxxxx" for each subfolder found in the first folder in column A resulting in 500 lines of "C:xxx\xxx\xx"

Hi Nilletnilsson,

I tested it on my end with 1500 folders and it works okay. It sounds like it may be capturing a large amount of folders on your end and that may be the issue. I posted a video on youtube showing an example of it working on my end that might let you see a performance issue you are seeing when you run it. Here is the video link if you want to view it. It is a couple of minutes long.

https://youtu.be/w9wmpLLuWH4

Thanks,

Dan

Hello Dan,

Thank you for the video.
I saw that you had 1500 different maps. Im doing it with 3,500 maps. 1main map 35 submaps and the rest of the 3464 maps are divided in the 35 submaps.
When i run the script just like you do it takes an enourmous amount of time. I've had it running for about 6 hours without any results. It looks like it's just looping if i watch the task bar in excel at the bottom left corner.
I know i have twice the amount of maps that you do but yours only took 1min, there must be something wrong?
Maybe it's the way i've built my map system on the computer?

Im running on a pretty decent computer so i think it's wierd that it takes that amount of time.

Hi Nilletnilsson,

The attached workbook has the example of the program working on my end. I also posted another video showing it at work, so you can use it as reference. I adjusted the programming so it captures over 3500 folders and it doesn't have any trouble. I did add a number of cycles limitation and also put in programming that provides for a 1 second delay to help the program not crash.

Anyway, if you are still looking for a solution, you can look at the video and use this example workbook to verify it works like it does on my end. Here is the link to the video: https://www.youtube.com/watch?v=q5eEB-kgS2k

Hope that helps,

Dan

Hello Dan,

I tried it with the excel file you sent and now it works perfectly! Took 1min to generate all maps.
I can't tank you enough, you've made my life so much easier.

A big thank you!

Hi Dan

I tried the code following your video and it worked great! I also tried the workbook you posted and worked perfect! Thank you very much for sharing this.

Glad to hear we found a solution. It was a fun problem to work with since I learned a few things myself.

Thanks,

Dan