【Excel VBA 编程】关键字+超链接,快速定位近期修改的文件

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