一. 单层文件夹
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
Columns(1).Clear: Cells(1, 1) = "目录": k = 1
strFileName = Dir(strPath & "*.*")
Do While strFileName <> ""
k = k + 1
ActiveSheet.Hyperlinks.Add Cells(k, 1), strPath & strFileName
strFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "一共读取了:" & k - 1 & "个文件名。"
End Sub
二. 多层文件夹
Sub AutoAddLink()
Dim strFldPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择指定文件夹。"
If .Show Then
strFldPath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False
Range("A:B").ClearContents
Range("A1:B1") = Array("文件夹", "文件名")
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
Set objFld = CreateObject("Scripting.FileSystemObject").GetFolder(strFldPath)
For Each objFile In objFld.Files
strFilePath = objFile.Path
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