Dim i As Integer '全局变量，用于定位工作表中位置Sub FindAndGetFiles() Dim folderPath As String, keyWords As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then folderPath = .SelectedItems(1) Else Exit Sub End With folderPath = folderPath & IIf(Right(folderPath, 1) = "\", "", "\") keyWords = InputBox("请输入关键字：", "关键字输入") ' If keyWords = "" Then MsgBox "未输入关键词，程序退出！" Exit Sub End If Call TraverseFolder(folderPath, keyWords) MsgBox "完成！", vbInformationEnd Sub
Sub TraverseFolder(folderPath As String, searchKey As String) Dim fso As Object, folder As Object, subFolder As Object, file As Object Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) ' 遍历当前文件夹文件 For Each file In folder.Files ' 检查文件名是否包含关键字（不区分大小写） If InStr(1, file.Name, searchKey, vbTextCompare) > 0 Then ' Excel文档并且是最近三天修改过的 If (Right(file.Name, 4) = "xlsx" Or Right(file.Name, 3) = "xls") And (Now - file.DateLastModified <= 3) Then ' 当前活动工作表（ActiveSheet）中插入超链接：A列文件名，B列超链接 Range("A2").Offset(i, 0).Value = file.Name ActiveSheet.Hyperlinks.Add Anchor:=Range("B2").Offset(i, 0), _ Address:=file.path, _ TextToDisplay:="打开文件" i = i + 1 End If End If Next file ' 递归遍历子文件夹 For Each subFolder In folder.SubFolders TraverseFolder subFolder.path, searchKey Next subFolder ' 释放对象 Set file = Nothing Set subFolder = Nothing Set folder = Nothing Set fso = NothingEnd Sub
