Excel - Create multiple folders and hyperlinks - vba

Question

I want/need to select cells on an Excel worksheet and create folders (called the same as the cell text) and also hyperlink the cell to the newly created folder.
I have managed to find a VBA that creates folders for selected cells and they are saving in the same location as the excel is saved....great saves me loads of time!
....but I would like to add to the VBA that the cell should link to the created folder, can anyone help? This is to save me hyperlinking each individual cell.
I wish I knew how to create these myself as I am amazed this looks like the matrix to me!
Below is the VBA that works to create the list of folders as per the name of the cell (I got this from forum):
Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub
Appreciate your help and please excuse my lack of knowledge with regard to this subject.

Answer 1

This should do the trick. I've replace your MakeFolders procedure with a shorter version.
Public Sub MakeHyperlinks()
Dim MyRange As Range
Dim rCell As Range
'List your folders in range A1:A4 - e.g. S:\Bartrup-CookD\Test\My New Folder 1
Set MyRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:A4")
For Each rCell In MyRange
'Create the folder.
CreateFolder rCell.Value
'Create the hyperlink.
rCell.Hyperlinks.Add Anchor:=rCell, _
Address:=Replace(rCell.Value, " ", "%20")
Next rCell
End Sub
Public Sub CreateFolder(Folder)
On Error Resume Next
Dim objFSO As Object: Set objFSO = CreateObject("Scripting.FileSystemObject")
If Folder <> "" Then
If Not objFSO.FileExists(objFSO.GetParentFolderName(Folder)) Then
Call CreateFolder(objFSO.GetParentFolderName(Folder))
End If
objFSO.CreateFolder (Folder)
End If
End Sub