Excel VBA：按文件名前6字符查找子文件夹文件并添加超链接求助

昨天我通过文件名前6个字符判断文件夹中是否存在对应文件，今日希望实现按文件名前6个字符查找子文件夹中的文件，并将找到的文件完整路径的超链接添加到Excel单元格中。目前仅能判断文件是否存在，请求协助编写相关代码。

现有代码片段 #

Const RootPath1 As String = "X:\DOSYALAR\ÜRETİM\FORMLAR"
Const SeriCol As Long = 3
Dim iCnt As Integer
iCnt = fn_LastRow(Sheets("Data")) + 1
Dim h2 As Hyperlink
Dim h2_name As String: h2_name = ws.Cells(iCnt, SeriCol)


With ws
 .Hyperlinks.Add Anchor:=.Cells(iCnt, SeriCol), _
 Address:=RootPath1, _
 ScreenTip:="Click to open order form", _
 TextToDisplay:=h2_name
End With

解决方案代码 #

1. 递归查找文件的函数 #

先添加一个递归遍历文件夹及子文件夹、匹配文件名前6个字符的函数：

' 递归查找匹配前6个字符的文件，返回第一个找到的文件完整路径
Function FindFileByFirst6Chars(rootPath As String, matchStr As String) As String
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(rootPath)
    
    ' 遍历当前文件夹的文件
    For Each file In folder.Files
        ' 匹配文件名前6个字符（区分大小写，如需不区分可套UCase/LCase转换）
        If Left(file.Name, 6) = matchStr Then
            FindFileByFirst6Chars = file.Path
            Exit Function ' 找到第一个匹配文件就返回
        End If
    Next file
    
    ' 递归遍历子文件夹
    For Each subFolder In folder.SubFolders
        FindFileByFirst6Chars = FindFileByFirst6Chars(subFolder.Path, matchStr)
        ' 找到文件就停止递归
        If FindFileByFirst6Chars <> "" Then Exit Function
    Next subFolder
    
    ' 未找到返回空字符串
    FindFileByFirst6Chars = ""
End Function

2. 修改主代码逻辑 #

替换原有的超链接添加部分，调用查找函数实现需求：

Const RootPath1 As String = "X:\DOSYALAR\ÜRETİM\FORMLAR"
Const SeriCol As Long = 3
Dim iCnt As Integer
Dim ws As Worksheet
Dim h2_name As String
Dim matchedFilePath As String

Set ws = Sheets("Data")
iCnt = fn_LastRow(ws) + 1 ' 确保fn_LastRow接收正确的工作表对象
h2_name = ws.Cells(iCnt, SeriCol).Value

' 检查单元格内容长度是否满足匹配要求
If Len(h2_name) >= 6 Then
    matchedFilePath = FindFileByFirst6Chars(RootPath1, Left(h2_name, 6))
    
    With ws
        .Hyperlinks.Delete Anchor:=.Cells(iCnt, SeriCol) ' 先删除原有超链接（若存在）
        If matchedFilePath <> "" Then
            ' 找到文件，添加对应路径的超链接
            .Hyperlinks.Add Anchor:=.Cells(iCnt, SeriCol), _
                Address:=matchedFilePath, _
                ScreenTip:="点击打开对应文件", _
                TextToDisplay:=h2_name
        Else
            ' 未找到文件，保留原文本并添加提示
            .Cells(iCnt, SeriCol).Value = h2_name & "（未找到对应文件）"
        End If
    End With
Else
    ' 内容不足6位，无法匹配，添加提示
    ws.Cells(iCnt, SeriCol).Value = h2_name & "（内容不足6位，无法匹配）"
End If

补充说明 #

• 递归函数会遍历指定根目录下所有子文件夹，返回第一个匹配的文件路径；若需匹配所有符合条件的文件，可修改函数返回路径数组，再批量处理超链接
• 代码中默认区分文件名大小写，如需忽略大小写，可将Left(file.Name, 6) = matchStr改为UCase(Left(file.Name, 6)) = UCase(matchStr)

内容的提问来源于stack exchange，提问作者mesyen