VBA 获取指定文件夹下的文件，创建超链接

---

一. 单层文件夹

Sub GetFiles()

    Dim strPath As String, strFileName As String, k As Long
    
    ' 用户选择文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        ' 如果用户未选择文件夹则退出程序
        If .Show Then 
            strPath = .SelectedItems(1) 
        Else
            Exit Sub
        End If
    End With
    
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False '取消屏幕刷新
    
    ' 清除当前工作表A列数据
    Columns(1).Clear: Cells(1, 1) = "目录": k = 1
    
    ' dir函数通过通配符获取首个文件名
    ' 如果一个文件也不存在，则返回空
    strFileName = Dir(strPath & "*.*")
    
    Do While strFileName <> ""
        ' 累加文件个数
        k = k + 1 
        ' 创建超链接
        ActiveSheet.Hyperlinks.Add Cells(k, 1), strPath & strFileName
        ' 第2次调用Dir函数，未使用任何参数，则同目录下的下一个文件名
        strFileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "一共读取了：" & k - 1 & "个文件名。"
    
End Sub

---

二. 多层文件夹

Sub AutoAddLink()

    Dim strFldPath As String
    
    ' 用户选择指定文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        ' 设置标题
        .Title = "请选择指定文件夹。"
        '未选择文件夹则退出程序，否则将地址赋予变量strFldPath
        If .Show Then
            strFldPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    ' 关闭屏幕刷新
    Application.ScreenUpdating = False
    
    ' 清除A,B列数据,并给A1,B1单元格赋予数据
    Range("A:B").ClearContents
    Range("A1:B1") = Array("文件夹", "文件名")
    
    ' 调取自定义函数SearchFileToHyperlinks
    Call SearchFileToHyperlinks(strFldPath)
    
    ' 自动列宽
    Range("a:b").EntireColumn.AutoFit
    ' 重开屏幕刷新
    Application.ScreenUpdating = True
    
End Sub

• CreateObject("Scripting.FileSystemObject")
  • 创建文件系统的访问和管理功能的对象
  • 可进行文件和文件夹的创建、复制、移动、删除等操作。
  • objFld.Files：获取所有文件
  • objFld.SubFolders：获取所有子文件夹
• InStrRev(strFilePath, "\")：
  • 用于在字符串中反向查找子字符串的函数。
  • InStrRev 函数会从指定的起始位置开始向字符串的起始位置反向搜索，找到指定子字符串第一次出现的位置，并返回其在字符串中的位置索引。

Function SearchFileToHyperlinks(ByVal strFldPath As String) As String

    Dim objFld As Object
    Dim objFile As Object
    Dim objSubFld As Object
    Dim strFilePath As String
    Dim lngLastRow As Long
    Dim intNum As Integer
    
    ' 创建FileSystemObject对象引用
    Set objFld = CreateObject("Scripting.FileSystemObject").GetFolder(strFldPath)
    
    ' 遍历文件夹内的文件
    For Each objFile In objFld.Files
    
        strFilePath = objFile.Path
        
        ' 使用InStrRev函数获取最后文件夹名截至的位置
        intNum = InStrRev(strFilePath, "\")
        
        lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        
        ' 从路径中获取出文件夹地址
        Cells(lngLastRow, 1) = Left(strFilePath, intNum - 1)
        ' 从路径中获取出文件名
        Cells(lngLastRow, 2) = Mid(strFilePath, intNum + 1)
        
        ' 添加超链接
        ActiveSheet.Hyperlinks.Add _
                    Anchor:=Cells(lngLastRow, 2), _
                    Address:=strFilePath, _
                    ScreenTip:=strFilePath
        
    Next objFile
    
    ' 遍历文件夹内的子文件夹
    For Each objSubFld In objFld.SubFolders
        ' 递归调用
        Call SearchFileToHyperlinks(objSubFld.Path)
    Next objSubFld
    
    ' 清除对象
    Set objFld = Nothing
    Set objFile = Nothing
    Set objSubFld = Nothing
    
End Function