Search Subfolders and hyperlink

[divinedar]

I have the following code that hyperlinks the file to a cell in excel when you type in the filename. I need to alter this code and not sure how. I need for the code that when you type in file name it also finds the filename in subfolders also. Right now it only does the top level folder, i need to check the top level folder and all subfolders for the file. Also to have it search for any extension, not just a .doc file. Also so you're aware the files that are being hyperlinked are on a server.

<code class="language-vb">Private Sub Worksheet_Change(ByVal Target As Range) </code>
<code class="language-vb">'change "c:\tmp\" to whatever reference you need </code>
<code class="language-vb">'a cell, a public variable, a fixed string </code>
<code class="language-vb">If Target.Column = 16 Then </code>
<code class="language-vb">MakeHyperLink Target, "C:\Temp" </code>
<code class="language-vb">End If </code>
<code class="language-vb">End Sub </code>
<code class="language-vb"></code>
<code class="language-vb">Public Function MakeHyperLink(InRange As Range, _ </code>
<code class="language-vb">ToFolder As String, _ </code>
<code class="language-vb">Optional InSheet As Worksheet, _ </code>
<code class="language-vb">Optional WithExt As String = "doc") As String </code>
<code class="language-vb">Dim rng As Range </code>
<code class="language-vb">Dim Filename As String </code>
<code class="language-vb">Dim Ext As String </code>
<code class="language-vb"></code>
<code class="language-vb">'check to see if folder has trailing \ </code>
<code class="language-vb">If Right(ToFolder, 1) <> "\" Then </code>
<code class="language-vb">Filename = ToFolder & "\" </code>
<code class="language-vb">Else </code>
<code class="language-vb">Filename = ToFolder </code>
<code class="language-vb">End If </code>
<code class="language-vb">'check to see if need ext </code>
<code class="language-vb">If WithExt <> "" Then </code>
<code class="language-vb">'check to see if ext has leading dot </code>
<code class="language-vb">If Left(WithExt, 1) <> "." Then </code>
<code class="language-vb">WithExt = "." & WithExt </code>
<code class="language-vb">End If </code>
<code class="language-vb">End If </code>
<code class="language-vb">
'if not explicit sheet then assign active </code>
<code class="language-vb">If InSheet Is Nothing Then </code>
<code class="language-vb">Set InSheet = ActiveSheet </code>
<code class="language-vb">End If </code>
<code class="language-vb">
'now for every cell in range </code>
<code class="language-vb">For Each rng In InRange </code>
<code class="language-vb">
'does range have value </code>
<code class="language-vb">If rng <> "" Then </code>
<code class="language-vb">
'make hyperlink to file </code>
<code class="language-vb">InSheet.Hyperlinks.Add Anchor:=rng, Address:= _ </code>
<code class="language-vb">Filename & rng.Text & WithExt, TextToDisplay:=rng.Text </code>
<code class="language-vb">End If </code>
<code class="language-vb"></code>
<code class="language-vb">Next </code>
<code class="language-vb"></code>
<code class="language-vb">End Function </code>

 

[divinedar]

Any help anyone?

 

[divinedar]

Still searching for help. Can anyone help?

Okay I'm still working on this and can't seem to get it to work properly. It's not that it's not working, it's slow and I need to search and replace some hyperlinks because when you close the workbook, you loose the links.


This is what I have that works but it's slow because there are subfolders and plenty files:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
If Target.Column = 7 Then
MakeHyperLink Target, "Q:\"
End If

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
<Option Explicit
Private Files As Dictionary
Private StrFile As String
Dim StrFlePath As String, FleCollection, fle, f1
Public Function MakeHyperLink(InRange As Range, _
ToFolder As String, _
Optional InSheet As Worksheet, _
Optional WithExt As String = "*") As String
Dim rng As Range
Dim Filename As String
Dim Ext As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

GetFileAddress
'check to see if folder has trailing \
If Right(ToFolder, 1) <> "\" Then
Filename = ToFolder & "\"
Else
Filename = ToFolder
End If
'check to see if need ext
If WithExt <> "" Then
'check to see if ext has leading dot
If Left(WithExt, 1) <> "." Then
WithExt = "." & WithExt
End If
End If
'if not explicit sheet then assign active
If InSheet Is Nothing Then
Set InSheet = ActiveSheet
End If
'now for every cell in range
For Each rng In InRange
'does range have value
If rng <> "" Then
'make hyperlink to file
StrFlePath = Files(UCase(rng.Text & WithExt))
InSheet.Hyperlinks.Add Anchor:=rng, Address:= _
StrFlePath, TextToDisplay:=rng.Text
End If
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Function
Sub GetFileAddress()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set Files = New Dictionary
FindFolder "Q:\"
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Public Function FindFolder(strPath As String) As String
Dim fs, f2, subfld
Set fs = CreateObject("scripting.filesystemobject"
Set f1 = fs.GetFolder(strPath)
Set f2 = f1.SubFolders
Set FleCollection = f1.Files
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

For Each fle In FleCollection
If Not (Files.Exists(UCase(fle.Name))) Then
Files.Add UCase(fle.Name), fle.Path
End If
Next
For Each subfld In f2
FindFolder subfld.Path
Next
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Function>
Also I need to replace some hyperlinks that already exist. What happen is when you close the workbook the links stop working and looses the beginning of the hyperlink.
This is the code that I have for that:
< Sub FindReplaceHLinks(sFind As String, sReplace As String, _
Optional lStart As Long = 1, Optional lCount As Long = -1)

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Dim rCell As Range
Dim hl As Hyperlink
For Each rCell In ActiveSheet.UsedRange.Cells
If rCell.Hyperlinks.Count > 0 Then
For Each hl In rCell.Hyperlinks
hl.Address = Replace(hl.Address, sFind, sReplace, lStart, lCount, vbTextCompare)
Next hl
End If
Next rCell

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

End Sub>

I would like to condense this as much as possible and see if that helps it work faster. The replacement code for the hyperlinks works but don't get all the hyperlinks on the worksheet. Would be nice if the the hyperlink replacement code could check each worksheet when it opens or by the click of a button that it would check all hyperlinks within the workbook.
Any ideas anybody. I really need help.