VBA searching for a folder, matching partial selected cell values.

[Bagsy]

I have some code thanks to Shinigamilight.
The code searches through folders & subfolders for folders named the same as the unique values in a selected range.
Once it finds the folder it inserts a hyperlink for that folder in the cell with the corresponding value in the selected range, then continues until all the selected cells are hyperlinked to the relevant folders.
This is working great as a test using identical values in the selected range as the names of the folders to hyperlink to.
However, this wasn’t all I needed to achieve, the highlighted range values are not identical (just similar) to the folder name I need to hyperlink to.
I Thought this would be easy to sort out once I had some help with the search code, by using some sort of wildcard but is much harder than I thought and beyond my capability.
The selected range of cells are always as the LH format, whereas the folders I am searching for are always named as the RH Format in below lists
SO1234.1 searching for folder WO1234.1.1
SO1234.2 searching for folder WO1234.2.1
SO1235.2 searching for folder WO1235.2.1
SO1235.10 searching for folder WO1235.10.1
SO12345.6 searching for folder WO12345.6.1
Is there anyway the code can be modified so I can achieve this.
All help is always appreciated.
Full code below.

Sub InsertHyperlinks()

Selection.Hyperlinks.Delete ' clearing any old hyperlinks
FolderSearcher "U:\QC Document Controller\Test\"     'just enter the file path, you have to run the macro from here
                       
End Sub

Sub FolderSearcher(ByVal Pather As String)
        Dim FSO As New Scripting.FileSystemObject 'enabled microsoft scriping runtime in the references
        Dim Fol As folder
        Dim Fol2 As folder
        Dim rng As Range, rng2 As Range
        Set Fol = FSO.GetFolder(Pather)
        Set rng = Selection
        
        For Each Fol2 In Fol.subfolders
                For Each rng2 In rng
                        If LCase(rng2.Value) = LCase(FSO.GetFileName(Fol2)) Then
                            Range("A1").Hyperlinks.Add rng2.Offset(0, 0), Fol2
                        End If
                Next rng2
                FolderSearcher Fol2
        Next Fol2
         
End Sub

 

[Bagsy]

Can anybody offer some advice on how I can achieve this please
Any help at all would be appreciated.

 

[Bagsy]

Anybody please, is this actually achievable or do I need a different approach

 

[shinigamilight]

I assumed that the name in the cell starts with 2 Alphabets and the folder name also starts with 2 alphabets. If you're data is much more diverse this won't work. Also this is searching the cell value in the folder name so if the cell value is partial then only it would work.

Sub InsertHyperlinks()

Selection.Hyperlinks.Delete ' clearing any old hyperlinks
FolderSearcher "C:\Users\Windows\Desktop\Test"     'just enter the file path, you have to run the macro from here
                       
End Sub

Sub FolderSearcher(ByVal Pather As String)
        Dim FSO As New Scripting.FileSystemObject 'enabled microsoft scriping runtime in the references
        Dim Fol As Folder
        Dim Fol2 As Folder
        Dim rng As Range, rng2 As Range
        Set Fol = FSO.GetFolder(Pather)
        Set rng = Selection
        Dim FileName, CellName As String
        
        For Each Fol2 In Fol.SubFolders
                    
                    For Each rng2 In rng
                                FileName = Right(FSO.GetFileName(Fol2), Len(FSO.GetFileName(Fol2)) - 2)
                                CellName = Right(rng2, Len(rng2) - 2)
                            If InStr(1, FileName, CellName) > 0 Then
                                Range("A1").Hyperlinks.Add rng2.Offset(0, 1), Fol2
                            End If
                    Next rng2
                
            FolderSearcher Fol2               ' RECURSIVE call
        Next Fol2
         
End Sub

 

[Bagsy]

Shinigamilight
That is exactly what I was trying to achieve, thank you so much