Multiple Private Subs and Functions in one sheet

[Nebucanezars]

I am trying to put multiple functions and private subs into one sheet but can't seem to get them to work all when put together.
See Excel attachment for the "Target.Hyperlinks.Count" part

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim x
    If Target.Count = 1 Then
        If Not Intersect(Target, Range("B2:B1000")) Is Nothing Then
            x = GetNum(Target(, 0))
                        If (x <> "") * (Target.Hyperlinks.Count = 0) Then Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:="B"
        End If
    End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

Currently this single VBA hyperlink button is working but once I try to add a second and/or third target hyperlink for different collums with the same function attaced to it from the source collumn I get compile errors.
Is there anyone who could help me out figuring this out? I tried to solve it via the following Else solution:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim x
    If Target.Count = 1 Then
        If Not Intersect(Target, Range("B2:B1000")) Is Nothing Then
            x = GetNum(Target(, 0))
                        If (x <> "") * (Target.Hyperlinks.Count = 0) Then Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:="B"
        Else
        If Target.Count = 1 Then
        If Not Intersect(Target, Range("C2:C1000")) Is Nothing Then
            x = GetNum(Target(, 0))
                        If (x <> "") * (Target.Hyperlinks.Count = 0) Then Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:="C"
         Else
        If Target.Count = 1 Then
        If Not Intersect(Target, Range("D2:D1000")) Is Nothing Then
            x = GetNum(Target(, 0))
                        If (x <> "") * (Target.Hyperlinks.Count = 0) Then Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:="D"
        End If
    End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

Once this is working the following code also needs to work in the same sheet on top of the above:

Option Explicit
Private fso As Object
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("K3:K250")) Is Nothing Then
            Call Open_Folder
        End If
    End If
End Sub
Sub Open_Folder()

Dim strRoot As String
Dim strID As String
Dim strFolder As String
Dim nMaxDepth As Long

strID = ActiveCell.Value
If strID = "False" Then Exit Sub 'User canceled input

strRoot = "V:\" ' Root path for all subfolders
If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"

nMaxDepth = 2 ' Maximum search depth

strFolder = FindFolder("V:\0. Test-0", strID, 1, 1)
If strFolder = "" Then strFolder = FindFolder("V:\1. Test-1", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\2. Test-2", strID, 4, 1)
If strFolder = "" Then strFolder = FindFolder("V:\3. Test-2", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\4. Test-4", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\5. Test-5", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\6. Test-6", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\7. Test-7", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\8. Test-8", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\9. Test-9", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\10. Test-10", strID, 2, 1)

If strFolder <> "" Then
    Shell "Explorer """ & strFolder & "", vbNormalFocus
Else
    MsgBox strID & "...", , "No Folder Found"
End If
    
End Sub
Function FindFolder(ByVal strPath As String, ByVal strID As String, nMaxDepth As Long, nDepth As Long) As String
                  
    Dim strFolder As String
    Dim fsoSubfolder As Object
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    DoEvents
    
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    On Error Resume Next
    
    ' Test current folder
    strFolder = Dir(strPath & strID & "*", vbDirectory)
    If strFolder <> "" Then
        FindFolder = strPath & strFolder
    ElseIf nDepth < nMaxDepth Then
        'Search sub folders
        For Each fsoSubfolder In fso.GetFolder(strPath).SubFolders
            FindFolder = FindFolder(fsoSubfolder.Path, strID, nMaxDepth, nDepth + 1)
            If FindFolder <> "" Then Exit For
        Next fsoSubfolder
    End If

End Function

Excel-VBA button hyperlink5.xlsm

[ByteMarks]

Does this work for you, replacing all of the other Worksheet_SelectionChange procedures?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
If Target.Count = 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        x = GetNum(Target(, 0))
        If (x <> "") * (Target.Hyperlinks.Count = 0) Then
            Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=Col
            Call Open_Folder
        End If
    End If
End If
End Sub

[Nebucanezars]

Ok step 1 first: I removed your line of code "Call Open_Folder"
So My code looks the following for the hyperlink button:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
If Target.Count = 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        x = GetNum(Target(, 0))
        If (x <> "") * (Target.Hyperlinks.Count = 0) Then
            Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=Col
        End If
    End If
End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

I tested it and it works, Column B gets the hyperlink button with the text to display using the column letter. (See attachment: Excel-VBA button hyperlink Test.xlsm)

Step 2: What I need it to do is also create a button for column C and column D using the same referal from column A.
But the hyperlink output and TextToDisplay needs to be different for each of the columns.

Something like this:
Column B: https://google.com=100" & x, TextToDisplay:=B
Column C: https://yahoo.com=100" & x, TextToDisplay:=X
Column D: https://excelforum.com=100" & x, TextToDisplay:=E

Once this step is set and working I will move on to my next point is implementing your recommendation of adding the "Call Open_Folder" to this Worksheet_SelectionChange procedure
Which eventually has to implement the following code which makes a button out of the column A data and searches and opens a folder on the V: disk.

Option Explicit
Private fso As Object
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("A2:A1000")) Is Nothing Then
            Call Open_Folder
        End If
    End If
End Sub
Sub Open_Folder()

Dim strRoot As String
Dim strID As String
Dim strFolder As String
Dim nMaxDepth As Long

strID = ActiveCell.Value
If strID = "False" Then Exit Sub 'User canceled input

strRoot = "V:" ' Root path for all subfolders
If Right(strRoot, 1) <> "" Then strRoot = strRoot & ""

nMaxDepth = 2 ' Maximum search depth

strFolder = FindFolder("V:\0. Test-0", strID, 1, 1)
If strFolder = "" Then strFolder = FindFolder("V:\1. Test-1", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\2. Test-2", strID, 4, 1)
If strFolder = "" Then strFolder = FindFolder("V:\3. Test-2", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\4. Test-4", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\5. Test-5", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\6. Test-6", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\7. Test-7", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\8. Test-8", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\9. Test-9", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\10. Test-10", strID, 2, 1)

If strFolder <> "" Then
    Shell "Explorer """ & strFolder & "", vbNormalFocus
Else
    MsgBox strID & "...", , "No Folder Found"
End If
    
End Sub
Function FindFolder(ByVal strPath As String, ByVal strID As String, nMaxDepth As Long, nDepth As Long) As String
                  
    Dim strFolder As String
    Dim fsoSubfolder As Object
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    DoEvents
    
    If Right(strPath, 1) <> "" Then strPath = strPath & ""
    
    On Error Resume Next
    
    ' Test current folder
    strFolder = Dir(strPath & strID & "*", vbDirectory)
    If strFolder <> "" Then
        FindFolder = strPath & strFolder
    ElseIf nDepth < nMaxDepth Then
        'Search sub folders
        For Each fsoSubfolder In fso.GetFolder(strPath).SubFolders
            FindFolder = FindFolder(fsoSubfolder.Path, strID, nMaxDepth, nDepth + 1)
            If FindFolder <> "" Then Exit For
        Next fsoSubfolder
    End If

End Function

[ByteMarks]

also create a button for column C and column D using the same referal from column A.

Whereabouts is the referral to column A?

[Nebucanezars]

To my understanding the following part was using the number from column A and removes the first 3 letters to the left ABC and adds 100 infront of it:

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

This solution was suggestion by someone else to replace my old code (see below) which has a refference to this number in column A:

Option Explicit
Private fso As Object

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("B2:B1000")) Is Nothing Then
             Target = ("https://google.com" & "/100" & Replace(Replace(Replace(Replace(Replace(Target.Offset(0, -1), "ABC", ""), "-1", ""), "-2", ""), "-3", ""), "-4", ""))
        End If
    End If
End Sub

[ByteMarks]

So should GetNum always operate on column A of the target row?

[Nebucanezars]

GetNum should always get the data from column A, or a different column if I would change all the numbers to a different column.
But in that case I will change the code referal myself to the designated column

[ByteMarks]

Ok so

x = GetNum(Target(, 0))

is always getting x from column A

How are you determining the display text?

[Nebucanezars]

On my previous VBA code I used the following line to display my output text:

Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=B

So for column B I might used the letter B as visual output and for column C I might use the letter X or the word HELLO

[ByteMarks]

How about this

So a column's associated show-text is stored in the array colAssociation
It'll loop through and if the target's column is found, which choose the associated text to show
If it's not found it'll use the column letter.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim colAssociation
Dim TextToShow$

colAssociation = Split("B,B|C,X|D,something else", "|") 'columns and associated show-text
If Target.Count = 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        For i = 0 To UBound(colAssociation)
            If Col = Split(colAssociation(i), ",")(0) Then
                TextToShow = Split(colAssociation(i), ",")(1)
                Exit For
            End If
        Next
        If Len(TextToShow) = 0 Then TextToShow = Col
        x = GetNum(Target(, 0))
        If (x <> "") * (Target.Hyperlinks.Count = 0) Then
            Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=TextToShow
        End If
    End If
End If
End Sub

[Nebucanezars]

I have put the following code in my sheet, Column B output is correct, column C en D generate no output, any idea what the cause is?
Additionally, the hyperlink for column C en D should be respectively https://yahoo.com=100 and https://excelforum.com=100

Also when selecting any cells in column A gives an error.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim colAssociation
Dim TextToShow$

colAssociation = Split("B,B|C,X|D,something else", "|") 'columns and associated show-text
If Target.Count = 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        For i = 0 To UBound(colAssociation)
            If Col = Split(colAssociation(i), ",")(0) Then
                TextToShow = Split(colAssociation(i), ",")(1)
                Exit For
            End If
        Next
        If Len(TextToShow) = 0 Then TextToShow = Col
        x = GetNum(Target(, 0))
        If (x <> "") * (Target.Hyperlinks.Count = 0) Then
            Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=TextToShow
        End If
    End If
End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

See excel sheetExcel-VBA button hyperlink Test3.xlsm

[ByteMarks]

Please try this

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim colAssociation
Dim TextToShow$

colAssociation = Split("B,B|C,X|D,something else", "|") 'columns and associated show-text
If Target.Count = 1 And Target.Column > 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        For i = 0 To UBound(colAssociation)
            If Col = Split(colAssociation(i), ",")(0) Then
                TextToShow = Split(colAssociation(i), ",")(1)
                Exit For
            End If
        Next
        If Len(TextToShow) = 0 Then TextToShow = Col
        
        x = GetNum(Cells(Target.Row, 1))
        If (x <> "") * (Target.Hyperlinks.Count = 0) Then
            Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=TextToShow
        End If
    End If
End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

[Nebucanezars]

You have no idea how much I appreciate your help, almost getting there.
The textual output in the cells is perfect now and the error is gone.

What is left now is the following:
column B needs: Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=TextToShow
column C needs: Me.Hyperlinks.Add Target, "https://yahoo.com=100" & x, TextToDisplay:=TextToShow
column D needs: Me.Hyperlinks.Add Target, "https://excelforum.com=100" & x, TextToDisplay:=TextToShow

Is there a certain way to put this in the code by If or some way else?

[ByteMarks]

I added an extra dimension to the ColAssociation array to hold the changeable part of the url

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim colAssociation
Dim TextToShow$, Url$

colAssociation = Split("B,B,google.com" & _
                      "|C,X,yahoo.com" & _
                      "|D,something else,excelforum.com" _
                       , "|")
                       
If Target.Count = 1 And Target.Column > 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        For i = 0 To UBound(colAssociation)
            If Col = Split(colAssociation(i), ",")(0) Then
                TextToShow = Split(colAssociation(i), ",")(1)
                Url = "https://" & Split(colAssociation(i), ",")(2) & "=100"
                Exit For
            End If
        Next
        If Len(TextToShow) = 0 Then TextToShow = Col
        If Len(Url) Then
            x = GetNum(Cells(Target.Row, 1))
            If (x <> "") * (Target.Hyperlinks.Count = 0) Then
                Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=TextToShow
            End If
        End If
    End If
End If
End Sub

[Nebucanezars]

Does this mean the hyperlink in "Me.Hyperlinks.Add Target, "https://google.com=100" & x, TextToDisplay:=TextToShow" needs to replaced with a reference towards the colAssociation?
Cause now it still is using the google url for all 3 columns.

[ByteMarks]

Sorry, yes you're right.

That should be replaced by the Url variable

Me.Hyperlinks.Add Target, Url & x, TextToDisplay:=TextToShow

Here's the full thing again

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim colAssociation
Dim TextToShow$, Url$

colAssociation = Split("B,B,google.com" & _
                      "|C,X,yahoo.com" & _
                      "|D,something else,excelforum.com" _
                       , "|")
                       
If Target.Count = 1 And Target.Column > 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        For i = 0 To UBound(colAssociation)
            If Col = Split(colAssociation(i), ",")(0) Then
                TextToShow = Split(colAssociation(i), ",")(1)
                Url = "https://" & Split(colAssociation(i), ",")(2) & "=100"
                Exit For
            End If
        Next
        If Len(TextToShow) = 0 Then TextToShow = Col
        If Len(Url) Then
            x = GetNum(Cells(Target.Row, 1))
            If (x <> "") * (Target.Hyperlinks.Count = 0) Then
                Me.Hyperlinks.Add Target, Url & x, TextToDisplay:=TextToShow
            End If
        End If
    End If
End If
End Sub

[Nebucanezars]

Outstanding! thanks for helping and in the process learning me understand VBA more and more!

Now there is only 1 step left which is combine the two VBA codes that work seperate from eachother but I am unable to combine.
With combine I mean put both codes into one worksheet under the Microsoft Excel Objects inside the VBA Project, because if I just stack them on top of eachother I get compile errors.
Or is there another way? I am not fimiliar yet with modules or how sheets actually work in handeling different kind of codes or how to even stack / seperate codes from eachother.

Combine this:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim colAssociation
Dim TextToShow$, Url$

colAssociation = Split("B,B,google.com" & _
                      "|C,X,yahoo.com" & _
                      "|D,something else,excelforum.com" _
                       , "|")
                       
If Target.Count = 1 And Target.Column > 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        For i = 0 To UBound(colAssociation)
            If Col = Split(colAssociation(i), ",")(0) Then
                TextToShow = Split(colAssociation(i), ",")(1)
                Url = "https://" & Split(colAssociation(i), ",")(2) & "=100"
                Exit For
            End If
        Next
        If Len(TextToShow) = 0 Then TextToShow = Col
        If Len(Url) Then
            x = GetNum(Cells(Target.Row, 1))
            If (x <> "") * (Target.Hyperlinks.Count = 0) Then
                Me.Hyperlinks.Add Target, Url & x, TextToDisplay:=TextToShow
            End If
        End If
    End If
End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

(the code that creates hyperlinks in column B / C / D from the data of column A)


With this:

Option Explicit
Private fso As Object
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("K3:K250")) Is Nothing Then
            Call Open_Folder
        End If
    End If
End Sub
Sub Open_Folder()

Dim strRoot As String
Dim strID As String
Dim strFolder As String
Dim nMaxDepth As Long

strID = ActiveCell.Value
If strID = "False" Then Exit Sub 'User canceled input

strRoot = "V:\" ' Root path for all subfolders
If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"

nMaxDepth = 2 ' Maximum search depth

strFolder = FindFolder("V:\0. Test-0", strID, 1, 1)
If strFolder = "" Then strFolder = FindFolder("V:\1. Test-1", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\2. Test-2", strID, 4, 1)
If strFolder = "" Then strFolder = FindFolder("V:\3. Test-2", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\4. Test-4", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\5. Test-5", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\6. Test-6", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\7. Test-7", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\8. Test-8", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\9. Test-9", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\10. Test-10", strID, 2, 1)

If strFolder <> "" Then
    Shell "Explorer """ & strFolder & "", vbNormalFocus
Else
    MsgBox strID & "...", , "No Folder Found"
End If
    
End Sub
Function FindFolder(ByVal strPath As String, ByVal strID As String, nMaxDepth As Long, nDepth As Long) As String
                  
    Dim strFolder As String
    Dim fsoSubfolder As Object
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    DoEvents
    
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    On Error Resume Next
    
    ' Test current folder
    strFolder = Dir(strPath & strID & "*", vbDirectory)
    If strFolder <> "" Then
        FindFolder = strPath & strFolder
    ElseIf nDepth < nMaxDepth Then
        'Search sub folders
        For Each fsoSubfolder In fso.GetFolder(strPath).SubFolders
            FindFolder = FindFolder(fsoSubfolder.Path, strID, nMaxDepth, nDepth + 1)
            If FindFolder <> "" Then Exit For
        Next fsoSubfolder
    End If

End Function

(the code that creates a button in column K and searches for a folder in a set range of folder on disk V: and opens this folder in explorer)

Excel-VBA button hyperlink Test4.xlsm

[ByteMarks]

Is strID the value in column A?
Assuming it is:

• Insert a rectangle shape, format it accordingly and call it "Button"

• Then put this code in the Sheet1 section

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim x$
Dim i%
Dim colAssociation
Dim TextToShow$, Url$
Dim shp As Shape

colAssociation = Split("B,B,google.com" & _
                      "|C,X,yahoo.com" & _
                      "|D,something else,excelforum.com" _
                       , "|")
                       
If Target.Count = 1 And Target.Column > 1 Then
    Col = Split(Target.Address, "$")(1)
    r = Target.Row
    If r >= 2 And r <= 1000 Then
        For i = 0 To UBound(colAssociation)
            If Col = Split(colAssociation(i), ",")(0) Then
                TextToShow = Split(colAssociation(i), ",")(1)
                Url = "https://" & Split(colAssociation(i), ",")(2) & "=100"
                Exit For
            End If
        Next
        If Len(TextToShow) = 0 Then TextToShow = Col
        If Len(Url) Then
            x = GetNum(Cells(Target.Row, 1))
            If (x <> "") * (Target.Hyperlinks.Count = 0) Then
                Me.Hyperlinks.Add Target, Url & x, TextToDisplay:=TextToShow
            End If
        End If
    End If
End If
On Error Resume Next
Set shp = Shapes("Button")
On Error GoTo 0
If Not shp Is Nothing Then
    With shp
        If Cells(Target.Row, "A") = "" Or Target.Row = 1 Then
            shp.Visible = False
        Else
            .Top = Cells(Target.Row, "K").Top
            .Left = Cells(Target.Row, "K").Left
            .Height = Cells(Target.Row, "K").Height
            .Width = Cells(Target.Row, "K").Width
            .Visible = True
        End If
    End With
End If
End Sub

• And this code in Module1

Option Explicit
Private fso As Object

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

Sub Open_Folder()
Dim strRoot As String
Dim strID As String
Dim strFolder As String
Dim nMaxDepth As Long

strID = ActiveSheet.Cells(ActiveCell.Row, "A").Value
'If strID = "False" Then Exit Sub 'User canceled input
If Len(strID) = 0 Then Exit Sub

strRoot = "V:\" ' Root path for all subfolders
If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"

nMaxDepth = 2 ' Maximum search depth

strFolder = FindFolder("V:\0. Test-0", strID, 1, 1)
If strFolder = "" Then strFolder = FindFolder("V:\1. Test-1", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\2. Test-2", strID, 4, 1)
If strFolder = "" Then strFolder = FindFolder("V:\3. Test-2", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\4. Test-4", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\5. Test-5", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\6. Test-6", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\7. Test-7", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\8. Test-8", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\9. Test-9", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\10. Test-10", strID, 2, 1)

If strFolder <> "" Then
    Shell "Explorer """ & strFolder & "", vbNormalFocus
Else
    MsgBox strID & "...", , "No Folder Found"
End If
    
End Sub

Function FindFolder(ByVal strPath As String, ByVal strID As String, nMaxDepth As Long, nDepth As Long) As String
    Dim strFolder As String
    Dim fsoSubfolder As Object
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    DoEvents
    
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    On Error Resume Next
    
    ' Test current folder
    strFolder = Dir(strPath & strID & "*", vbDirectory)
    If strFolder <> "" Then
        FindFolder = strPath & strFolder
    ElseIf nDepth < nMaxDepth Then
        'Search sub folders
        For Each fsoSubfolder In fso.GetFolder(strPath).SubFolders
            FindFolder = FindFolder(fsoSubfolder.Path, strID, nMaxDepth, nDepth + 1)
            If FindFolder <> "" Then Exit For
        Next fsoSubfolder
    End If

End Function

• Assign the macro Open_folder to the button-shape created earlier

The button-shape will then appear in the column of the active row and run Open_folder when clicked

[Nebucanezars]

I was about to make a reply after I did some reading. I will definitely try your suggested solution.

What I was thinking is the following:
Put code 1 in Module1
Put code 2 in Module2
Create a code in sheet 1: saying the following, on Cell Range("B3:B250") apply Module1, on Cell Range("K3:K250") activate Module2, etc.

Is something like this possible?

[ByteMarks]

The selection_change routine has to remain in the worksheet.

So clicking in B to D will add the hyperlink.

Clicking in column K will open the folder. In the Open _Folder procedure

In the original code, strID was the activecell value, which will column K, so this might do it.

All in Sheet1

Option Explicit
Private fso As Object

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim x$
Dim i%
Dim colAssociation
Dim TextToShow$, Url$

colAssociation = Split("B,B,google.com" & _
                      "|C,X,yahoo.com" & _
                      "|D,something else,excelforum.com" _
                       , "|")
                       
If Target.Count = 1 And Target.Column > 1 Then
    Col = Split(Target.Address, "$")(1)
    If Col = "K" Then
        Call Open_Folder
    Else
        r = Target.Row
        If r >= 2 And r <= 1000 Then
            For i = 0 To UBound(colAssociation)
                If Col = Split(colAssociation(i), ",")(0) Then
                    TextToShow = Split(colAssociation(i), ",")(1)
                    Url = "https://" & Split(colAssociation(i), ",")(2) & "=100"
                    Exit For
                End If
            Next
            If Len(TextToShow) = 0 Then TextToShow = Col
            If Len(Url) Then
                x = GetNum(Cells(Target.Row, 1))
                If (x <> "") * (Target.Hyperlinks.Count = 0) Then
                    Me.Hyperlinks.Add Target, Url & x, TextToDisplay:=TextToShow
                End If
            End If
        End If
    End If
End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

Sub Open_Folder()

Dim strRoot As String
Dim strID As String
Dim strFolder As String
Dim nMaxDepth As Long

strID = ActiveCell.Value
If strID = "" Then Exit Sub 'User canceled input

strRoot = "V:\" ' Root path for all subfolders
If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"

nMaxDepth = 2 ' Maximum search depth

strFolder = FindFolder("V:\0. Test-0", strID, 1, 1)
If strFolder = "" Then strFolder = FindFolder("V:\1. Test-1", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\2. Test-2", strID, 4, 1)
If strFolder = "" Then strFolder = FindFolder("V:\3. Test-2", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\4. Test-4", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\5. Test-5", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\6. Test-6", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\7. Test-7", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\8. Test-8", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\9. Test-9", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\10. Test-10", strID, 2, 1)

If strFolder <> "" Then
    Shell "Explorer """ & strFolder & "", vbNormalFocus
Else
    MsgBox strID & "...", , "No Folder Found"
End If
    
End Sub

Function FindFolder(ByVal strPath As String, ByVal strID As String, nMaxDepth As Long, nDepth As Long) As String
                  
    Dim strFolder As String
    Dim fsoSubfolder As Object
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    DoEvents
    
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    On Error Resume Next
    
    ' Test current folder
    strFolder = Dir(strPath & strID & "*", vbDirectory)
    If strFolder <> "" Then
        FindFolder = strPath & strFolder
    ElseIf nDepth < nMaxDepth Then
        'Search sub folders
        For Each fsoSubfolder In fso.GetFolder(strPath).SubFolders
            FindFolder = FindFolder(fsoSubfolder.Path, strID, nMaxDepth, nDepth + 1)
            If FindFolder <> "" Then Exit For
        Next fsoSubfolder
    End If

End Function

[Nebucanezars]

ByteMarks thanks for all the help and teaching me more about VBA and how to approach things, I cant thank you enough.
Its working perfectly and exactly how I wanted.

I hope it will also help for anyone looking to do the same

Final working code:

Option Explicit
Private fso As Object

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Col$, r&
Dim x$
Dim i%
Dim colAssociation
Dim TextToShow$, Url$

colAssociation = Split("B,B,google.com" & _
                      "|C,X,yahoo.com" & _
                      "|D,something else,excelforum.com" _
                       , "|")
                       
If Target.Count = 1 And Target.Column > 1 Then
    Col = Split(Target.Address, "$")(1)
    If Col = "K" Then
        Call Open_Folder
    Else
        r = Target.Row
        If r >= 2 And r <= 1000 Then
            For i = 0 To UBound(colAssociation)
                If Col = Split(colAssociation(i), ",")(0) Then
                    TextToShow = Split(colAssociation(i), ",")(1)
                    Url = "https://" & Split(colAssociation(i), ",")(2) & "=100"
                    Exit For
                End If
            Next
            If Len(TextToShow) = 0 Then TextToShow = Col
            If Len(Url) Then
                x = GetNum(Cells(Target.Row, 1))
                If (x <> "") * (Target.Hyperlinks.Count = 0) Then
                    Me.Hyperlinks.Add Target, Url & x, TextToDisplay:=TextToShow
                End If
            End If
        End If
    End If
End If
End Sub

Function GetNum(ByVal txt As String) As String
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d+(?=(\-|$))"
        If .Test(txt) Then GetNum = .Execute(txt)(0)
    End With
End Function

Sub Open_Folder()

Dim strRoot As String
Dim strID As String
Dim strFolder As String
Dim nMaxDepth As Long

strID = ActiveCell.Value
If strID = "" Then Exit Sub 'User canceled input

strRoot = "V:\" ' Root path for all subfolders
If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"

nMaxDepth = 2 ' Maximum search depth

strFolder = FindFolder("V:\0. Test-0", strID, 1, 1)
If strFolder = "" Then strFolder = FindFolder("V:\1. Test-1", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\2. Test-2", strID, 4, 1)
If strFolder = "" Then strFolder = FindFolder("V:\3. Test-2", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\4. Test-4", strID, 3, 1)
If strFolder = "" Then strFolder = FindFolder("V:\5. Test-5", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\6. Test-6", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\7. Test-7", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\8. Test-8", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\9. Test-9", strID, 2, 1)
If strFolder = "" Then strFolder = FindFolder("V:\10. Test-10", strID, 2, 1)

If strFolder <> "" Then
    Shell "Explorer """ & strFolder & "", vbNormalFocus
Else
    MsgBox strID & "...", , "No Folder Found"
End If
    
End Sub

Function FindFolder(ByVal strPath As String, ByVal strID As String, nMaxDepth As Long, nDepth As Long) As String
                  
    Dim strFolder As String
    Dim fsoSubfolder As Object
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    DoEvents
    
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    On Error Resume Next
    
    ' Test current folder
    strFolder = Dir(strPath & strID & "*", vbDirectory)
    If strFolder <> "" Then
        FindFolder = strPath & strFolder
    ElseIf nDepth < nMaxDepth Then
        'Search sub folders
        For Each fsoSubfolder In fso.GetFolder(strPath).SubFolders
            FindFolder = FindFolder(fsoSubfolder.Path, strID, nMaxDepth, nDepth + 1)
            If FindFolder <> "" Then Exit For
        Next fsoSubfolder
    End If

End Function

[ByteMarks]

You're welcome.

[Nebucanezars]

Topic reopened!
In have been fiddeling around with all the codes but there is one thing I cant seem to get to work.

If I change the following code from:

colAssociation = Split("B,B,google.com" & _
                      "|C,X,yahoo.com" & _
                      "|D,something else,excelforum.com" _
                       , "|")

To this code:

colAssociation = Split("H,B,google.com" & _
                      "|N,X,yahoo.com" & _
                      "|M,something else,excelforum.com" _
                       , "|")

In other words I changed the column output/hyperlinks from B/C/D to H/N/M and my source column with the ABC123456 number isnt in column A anymore but column L.

I cant seem to get this part working anymore. anyone can give me a nudge in the right direction?

[ByteMarks]

If the numbers are now in column L instead of A, you need to change

x = GetNum(Cells(Target.Row, 1))

to

x = GetNum(Cells(Target.Row, "L"))

[Nebucanezars]

Thanks again, problem solved, topic SOLVED