Automatically add hyperlinks when typing a serial number

[AliKaffe]

Hello!
I work for a company that sells and services pumps.
I am attempting to make a excel sheet that will give us an overview of the pumps we service and sell.
I would like to make a macro that will automatically add a hyperlink to a file with the same file name on our server when i type the serial number in column L.
So i would like it to search the folder we put our Servicereports in, and add a hyperlink to the file if it finds a text in that column that matches the file name in the folder.
if possible i would also like it to search sub folders.
Is this possible?

if you see the image, i already added some hyper link manually. But would like this to happen automatically when i create a file in the folder with the same name.

 

[Legacy 456155]

Hi Ali.
Name your serial number range where the data entry will take place. Name it "SerialNumberRange".
Add a reference to Microsoft Scripting Runtime.
Paste this code in your worksheet class module.
If you have any trouble getting it working, I'll upload a link to an example.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [SerialNumberRange]) Is Nothing Then
        If Target.CountLarge = 1 Then If Len(Target) > 0 Then TryAddLink Target
    End If
End Sub

Private Sub TryAddLink(ByVal Target As Range)
    Static d As Dictionary
    Dim fso As New FileSystemObject
    
    If d Is Nothing Then
        Set d = New Dictionary
        '                         change to root folder
        GetFileList fso.GetFolder("C:\MyRootFolder"), d
    End If
    
    If d.Exists(Target.Text) Then Target.Hyperlinks.Add Target, d(Target.Text)
End Sub

Private Sub GetFileList(Folder As Scripting.Folder, d As Dictionary)
    Static fso As New FileSystemObject
    Dim SubFolder As Scripting.Folder
    Dim File As Scripting.File
    
    For Each SubFolder In Folder.SubFolders
        GetFileList SubFolder, d
    Next
    
    For Each File In Folder.Files
        If Not d.Exists(File.ShortName) Then
            d.Add fso.GetBaseName(File.Name), File.Path
        End If
    Next
End Sub

 

[AliKaffe]

Hello again!
i can't seem to get this to work. i get a compile error in this line: Private Sub GetFileList(Folder As Scripting.Folder, d As Dictionary)
i did enable Microsoft scripting runtime

added a picture of how i did it.

 

[Legacy 456155]

I don't know. I just tested it and it worked. See folder "Auto Hyperlinker" in this folder. Download the folder and test as is.

 

[AliKaffe]

it works. But it can't find the path on the server. Is this because of it being a remote server with it's own ip adress? is there a way to get around this?
On my computer the path looks like this: Z:\Test\Tine\Pumper
But it also has a ip adress.

 

[Legacy 456155]

I don't know. I don't recall having any issues with mapped drives and FSO. Have you tried using the UNC path?

 

[AliKaffe]

here is a screenshot of how the code looks with my path in it. it does nothing. Am i doing something wrong?

 

[Legacy 456155]

Use:
GetFileList fso.GetFolder("Z:\Test\Tine\Pumper"), d
That will be your root folder.
The code, as is, must be placed in the worksheet module that receives the data entry.

Name your range that will receive the serial numbers: SerialNumberRange

 

[AliKaffe]

ok. so it was working perfectly until today. now i get this error, but i can't find something wrong. i do have limited skills with this though, so any help would be great.

 

[Legacy 456155]

Logic error on my part.

Try this. The example was updated as well.
The error you received means that the same filename exists in multiple places. This code will grab the first instance it comes across.

Private Sub GetFileList(Folder As Scripting.Folder, d As Dictionary)
    Static fso As New FileSystemObject
    Dim SubFolder As Scripting.Folder
    Dim File As Scripting.File
    Dim Key As String
   
    For Each SubFolder In Folder.SubFolders
        GetFileList SubFolder, d
    Next
   
    For Each File In Folder.Files
        Key = fso.GetBaseName(File.Name)
        If Not d.Exists(Key) Then
            d.Add Key, File.Path
        End If
    Next
End Sub