Modify Macro Formula - Auto Hyperlink Selected Cells

1. Please edit your previous post by adding code tags around your code
(click on Edit Post,select the VBA text, and click on the # icon)
2. What is currently included in the cell text - does it include the current file path or only the text to build up the file name?
thanks

I have assumed that your selected cells contain the file name (including extension) and not the path

- if this is not a correct assumption then amend the 2 lines

sAddress = myFolder.Path & "\" & myfile.Name
sAddress = mySubFolder.Path & "\" & myfile.Name

to build your string differently - perhaps this (??)

sAddress = myFolder.Path & "\" & "PDFS" &  Replace(c.Text, " ", "") & ".pdf"
sAddress = mySubFolder.Path & "\" & "PDFS" &  Replace(c.Text, " ", "") & ".pdf"

Also amend this line

Array("L:\Documents\Excel\", "L:\Documents\Blog")

to include a list of your main folders to search (VBA will also search all their subfolders)
- include each path in " " and separated by commas


To run the macro :Select your cells and run sub AddLinks


The code will not work unless VBA Reference is added for Microsoft Scripting Runtime

VBA References.jpg

VBA References Scripting Runtime.jpg

This code should be placed in a General module.

Function FindFiles(sPath As String) As String
'require reference Microsoft Scripting Runtime
    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder

    Set Rng = Selection
    For Each c In Selection
    
    Set myFolder = FSO.GetFolder(sPath)
            For Each myfile In myFolder.Files
                If myfile.Name = c.Value Then
                    sAddress = myFolder.Path & "\" & myfile.Name
                    c.Parent.Hyperlinks.Add Anchor:=c, Address:=sAddress, TextToDisplay:=c.Text
                    GoTo TryNextCell
                End If
            Next myfile
    
    For Each mySubFolder In myFolder.SubFolders
            For Each myfile In mySubFolder.Files
                If myfile.Name = c.Value Then
                    sAddress = mySubFolder.Path & "\" & myfile.Name 
                    c.Parent.Hyperlinks.Add Anchor:=c, Address:=sAddress, TextToDisplay:=c.Text
                    GoTo TryNextCell
                End If
            Next myfile

       FindFiles = FindFiles(mySubFolder.Path)
    Next
TryNextCell:
    Next c
End Function

Sub AddLinks()
    Dim folderToSearch As String, a As Integer, myArray
    myArray = Array("L:\Documents\Excel\", "L:\Documents\Blog")
        For a = 0 To UBound(myArray)
            folderToSearch = myArray(a)
            Call FindFiles(folderToSearch)
    Next a
End Sub

Hi Kev,

Thanks for your response but I think I'm not doing it right!

The file name in excel does not contain any file extension. i.e. CP1-SDW-ME-00001

PDF Files Folder Location: F:\COMPANY\PROJECTS\TDO-18-TTC-0019\DESIGN DATA\01_SCHEMATIC DESIGN\IRSD#1 - 17-Jan-17\Drawings or Documents or Model
Subfolders under 17-Jan-17 Folder are: Drawings, Documents, Model - I want this code to search particular in these folder location.

Excel File Location: Z:\COMPANY\12.DOC-CONTROL\EDRMS\Master Log - Technical Submittal

The Microsoft Scripting Runtime is Activated - I think this is the only one I got right!

Thanks,
Mielkew

Function FindFiles(sPath As String) As String
'require reference Microsoft Scripting Runtime
    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder

    Set Rng = Selection
    For Each c In Selection
    
    Set myFolder = FSO.GetFolder(sPath)
            For Each myfile In myFolder.Files
                If myfile.Name = c.Value Then
                    sAddress = myFolder.Path & "\" & Replace(c.Text, " ", "") & ".pdf"
                    c.Parent.Hyperlinks.Add Anchor:=c, Address:=sAddress, TextToDisplay:=c.Text
                    GoTo TryNextCell
                End If
            Next myfile
    
    For Each mySubFolder In myFolder.SubFolders
            For Each myfile In mySubFolder.Files
                If myfile.Name = c.Value Then
                    sAddress = mySubFolder.Path & "\" & Replace(c.Text, " ", "") & ".pdf"
                    c.Parent.Hyperlinks.Add Anchor:=c, Address:=sAddress, TextToDisplay:=c.Text
                    GoTo TryNextCell
                End If
            Next myfile

       FindFiles = FindFiles(mySubFolder.Path)
    Next
TryNextCell:
    Next c
End Function

Sub AddLinks()
    Dim folderToSearch As String, a As Integer, myArray
    myArray = Array("F:\COMPANY\PROJECTS\TDO-18-TTC-0019\DESIGN DATA\01_SCHEMATIC DESIGN\IRSD#1 - 17-Jan-17\")
        For a = 0 To UBound(myArray)
            folderToSearch = myArray(a)
            Call FindFiles(folderToSearch)
    Next a
End Sub

I will look at this for you shortly
In the meantime, please click EDIT on your previous post and put code tags around your code
(select your code and then click on # icon)
thanks

That was easy. I posted your code into a clean file and with a minor modification it worked
I apologise -I forgot to tell you to amend the lines that check for each name (to match what you amended in building up the link address)

This needs amending on BOTH lines (to add the ".pdf" extension)

 If myfile.Name = c.Value & ".pdf" Then

If it still does not work then look at the message box (returned by the line below) to confirm that the file name matches exactly with the actual file name in the folder

MsgBox = Replace(c.Text, " ", "") & ".pdf"

Insert this line immediately below this line

For Each c In Selection

After you get it working for one folder I will help you tailor it to search all the specific folders you want

Hi Kev,

I think the code is working now but the files are not opening. As you can see in the excel list only those files that matched has the hyperlink.

I did insert this Code

MsgBox = Replace(c.Text, " ", "") & ".pdf"

After this line but I'm getting an error.

For Each c In Selection
MsgBox = Replace(c.Text, " ", "") & ".pdf"

        Set myFolder = FSO.GetFolder(sPath)
            For Each myfile In myFolder.Files
                If myfile.Name = c.Value & ".pdf" Then
                    sAddress = myFolder.Path & "\" & Replace(c.Text, " ", "") & ".pdf"
                    c.Parent.Hyperlinks.Add Anchor:=c, Address:=sAddress, TextToDisplay:=c.Text
                    GoTo TryNextCell

This is the Code I'm using now, sorry I really don't have any knowledge about VBA coding:

Function FindFiles(sPath As String) As String
'require reference Microsoft Scripting Runtime
    Dim FSO As New FileSystemObject
    Dim myFolder As Folder
    Dim mySubFolder As Folder

    Set Rng = Selection
    For Each c In Selection
    
    Set myFolder = FSO.GetFolder(sPath)
            For Each myfile In myFolder.Files
                If myfile.Name = c.Value & ".pdf" Then
                    sAddress = myFolder.Path & "\" & Replace(c.Text, " ", "") & ".pdf"
                    c.Parent.Hyperlinks.Add Anchor:=c, Address:=sAddress, TextToDisplay:=c.Text
                    GoTo TryNextCell
                End If
            Next myfile
    
    For Each mySubFolder In myFolder.SubFolders
            For Each myfile In mySubFolder.Files
                If myfile.Name = c.Value & ".pdf" Then
                    sAddress = mySubFolder.Path & "\" & Replace(c.Text, " ", "") & ".pdf"
                    c.Parent.Hyperlinks.Add Anchor:=c, Address:=sAddress, TextToDisplay:=c.Text
                    GoTo TryNextCell
                End If
            Next myfile

       FindFiles = FindFiles(mySubFolder.Path)
    Next
TryNextCell:
    Next c
End Function

Sub AddLinks()
    Dim folderToSearch As String, a As Integer, myArray
    myArray = Array("E:\HBK\PROJECTS\TDO-16-TTC-0018\DESIGN DATA\01_SCHEMATIC DESIGN\IRSD#1 - 17-Jan-17\")
        For a = 0 To UBound(myArray)
            folderToSearch = myArray(a)
            Call FindFiles(folderToSearch)
    Next a
End Sub

Replace

MsgBox = Replace(c.Text, " ", "") & ".pdf"

with

MsgBox Replace(c.Text, " ", "") & ".pdf"