Private Sub Worksheet_Change(ByVal Target As Range)
Const sPath = "C:\TEST\"
Dim sFilename As String, sCode As String
sCode = Target.Text
If Intersect(Target, Columns("A")) Is Nothing Or _
Target.Count > 1 Or _
sCode = vbNullString Then Exit Sub
On Error GoTo CleanUp
Application.EnableEvents = False
sFilename = FindFileMatch(sPath, sCode & "*")
If sFilename = vbNullString Then
MsgBox "No matching files found for code " & sCode
Else
Me.Hyperlinks.Add _
Anchor:=Target, Address:=sFilename, _
TextToDisplay:=sFilename
End If
CleanUp:
Application.EnableEvents = True
End Sub
Private Function FindFileMatch(ByVal sPath As String, _
ByVal sPattern As String) As String
[COLOR="Teal"]'---Searches sPath and its Subfolders for file matching sPattern
'--- returns first match[/COLOR]
Dim sSubFolders() As String
Dim sFile As String, sMatch As String
Dim lCnt As Long, i As Long
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
On Error Resume Next
sFile = Dir(sPath & "*.*", vbDirectory)
Do While Len(sFile) > 0
If Left(sFile, 1) <> "." Then
If (GetAttr(sPath & sFile) And vbDirectory) = vbDirectory Then
lCnt = lCnt + 1
ReDim Preserve sSubFolders(1 To lCnt)
sSubFolders(lCnt) = sPath & sFile
End If
If sFile Like sPattern Then
FindFileMatch = sPath & sFile
Exit Function
End If
End If
sFile = Dir
Loop
For i = 1 To lCnt
sMatch = FindFileMatch(sSubFolders(i), sPattern)
If sMatch <> vbNullString Then
FindFileMatch = sMatch
Exit Function
End If
Next i
FindFileMatch = vbNullString
End Function
