Public blnFolderFound As Boolean
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function gUsername() As String
Dim lngLen As Long
Dim strBuffer As String
Const dhcMaxUserName = 255
strBuffer = Space(dhcMaxUserName)
lngLen = dhcMaxUserName
If CBool(GetUserName(strBuffer, lngLen)) Then gUsername = Left$(strBuffer, lngLen - 1)
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim endRow As Long
Dim rng As Range, c As Range
Dim currPath As String
endRow = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row
Set rng = Range(Cells(1, 3), Cells(endRow, 3))
For Each c In rng
If c.Value <> vbNullString And c.Hyperlinks.Count = 0 Then
Cells(c.Row, 1).Value = Cells(c.Row, 3).Value & "_" & Cells(c.Row, 2).Value
currPath = ThisWorkbook.Path
If currPath = vbNullString Then currPath = "C:\Users\" & gUsername & "\Desktop"
folderExists currPath, Cells(c.Row, 1).Value
If blnFolderFound = True Then GoTo nextCellToCheck
ActiveSheet.Hyperlinks.Add Anchor:=c, Address:=currPath & "\" & Cells(c.Row, 1).Value, TextToDisplay:=c.Value
Else: End If
nextCellToCheck:
blnFolderFound = False
Next c
Set rng = Nothing
End Sub
Function folderExists(s_directory As String, s_folderName As String)
Dim obj_fso As Object, obj_dir As Object, obj_folder As Object
Set obj_fso = CreateObject("Scripting.FileSystemObject")
Set obj_dir = obj_fso.GetFolder(s_directory)
For Each obj_folder In obj_dir.SubFolders
If obj_fso.folderExists(s_directory & "\" & s_folderName) = True Then blnFolderFound = True: Exit For
Next
If blnFolderFound = False Then obj_fso.CreateFolder (s_directory & "\" & s_folderName)
Set obj_fso = Nothing
Set obj_dir = Nothing
End Function