I need help in VBA for finding a full file name from partial selected text-CodePudding

I have little no experience with VBA and have tried to start learning and picking it up recently. I grabbed someone else's code and have tried multiple different functions to make it fit my needs but I'm having issues. At work we use a word document for PLC reports pretty often, and I'm trying to make a macro where it will take the selected text(Like a station number, BM150 for example), and find a file from the partial text within any subfolder from the designated path and then hyperlink to it.

Sub HLink_Selected_Text()
Dim strPath As String
Dim StrSelection As Range
Dim sName As String
Dim fs As String

strPath = "filepath" 'the path to search

    Set StrSelection = Selection.Range
    sName = Dir$(strPath & Trim(StrSelection.Text) & ".*") 'change extension to ".*") for any file
    fs = strPath & sName
    If Not sName = "" Then
        StrSelection.Hyperlinks.Add Anchor:=StrSelection, Address:=fs, TextToDisplay:=Trim(StrSelection.Text)
    Else
        MsgBox "Matching document not found"
    End If
End Sub

This code works fantastically if I type out the EXACT file name and EXACT file path but we only input part of the file name in our report, and I want it to search multiple subfolders. Any help would be appreciated.

CodePudding user response：

Find File Using a Partial File Name

Uses the function to return all matching file paths in an array and creates a hyperlink to the first matching file.

Option Explicit

Sub HLink_Selected_Text_Word()
    
    Const FolderPath As String = "C:\Test"  'the path to search
    
    Dim strSelection As Range: Set strSelection = Selection.Range
    Dim Partial As String: Partial = Trim(strSelection.Text)
    Dim FilePattern As String: FilePattern = "*" & Partial & "*.*" ' contains
    'FilePattern = Partial & "*.*" ' begins with
    'FilePattern = "*" & Partial & ".*" ' ends with
    
    Dim FilePaths As Variant: FilePaths = ArrFilePaths(FolderPath, FilePattern)
    Dim fUpper As Long: fUpper = UBound(FilePaths)
    
    Dim fPath As String
    Dim fName As String
    
    If fUpper >= 0 Then ' there could be multiple matches
        fPath = FilePaths(0) ' using the first match '(0)'
        fName = Dir(FilePaths(0))
        strSelection.Hyperlinks.Add Anchor:=strSelection, Address:=fPath, _
            TextToDisplay:=Partial
        If fUpper > 0 Then
            MsgBox "Matching documents found: " & fUpper   1 & vbLf _
                & Join(FilePaths), vbExclamation
        End If
    Else
        MsgBox "Matching document not found"
    End If
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the file paths of the files in a folder in an array.
'               'b'   - to get file paths (e.g. 'C:\Test\Test.txt')
'               's'   - to search in subfolders
'               'a-d' - to exclude directories (folders)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*.*", _
    Optional ByVal DirSwitches As String = "/s/b/a-d") _
As Variant
    Const ProcName As String = "ArrFilePaths"
    On Error GoTo ClearError
    
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
    ExecString = "%comspec% /c Dir """ _
        & FolderPath & FilePattern & """ " & DirSwitches
    ArrFilePaths = Split(CreateObject("WScript.Shell") _
        .Exec(ExecString).StdOut.ReadAll, vbCrLf)

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

CodePudding user response：

Here is a code to get a list of files in folder (the path to search): FilesInFolderAndSubfolders return array of filenames.

Private Function FilesInFolderAndSubfolders(ByVal folderspec As String) As String()
    Dim arrFiles() As String
    Dim fso As Object   'file system object
    Dim currentFolder   'current folder in file system object
    Dim subFolder       'every subfolder
    
    'creating file system object
    Set fso = CreateObject("Scripting.FilesystemObject")
    
    Set currentFolder = fso.GetFolder(folderspec)   'get currentdirectory object
    
    'file list in current path
    FilesInFolder fso, folderspec, arrFiles
    
    'files lists in subfolders
    For Each subFolder In currentFolder.SubFolders
        FilesInFolder fso, subFolder.Path, arrFiles
    Next subFolder
    
    Set fso = Nothing
    Set currentFolder = Nothing
    Set subFolder = Nothing
    
    FilesInFolderAndSubfolders = arrFiles

End Function


Private Sub FilesInFolder(ByRef fso As Object, ByVal folderPath As String, ByRef arrFiles() As String)
    Dim currentFolder
    Dim file
    
    Set currentFolder = fso.GetFolder(folderPath)
    
    For Each file In currentFolder.files
        If Not Not arrFiles() Then 'if table exist
            ReDim Preserve arrFiles(LBound(arrFiles) To UBound(arrFiles)   1)
        Else
            ReDim arrFiles(0)
        End If
        arrFiles(UBound(arrFiles)) = folderPath & "\" & file.Name
    Next file

    Set file = Nothing
    Set currentFolder = Nothing
End Sub