求一个读取某文件文件名代码
请各位VB高手写个代码，该代码可以读取某文件夹里面指定含有关键字的文件名，是xlsx类型的，不显示后缀名 按最新文件日期显示在窗口里的头条，并且用鼠标点击该文件名就可以打开该文件！谢谢！
Sub 获取分表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i, arr(1 To 1000, 1 To 1), f, wb As Workbook, sht As Worksheet
For Each sht In Sheets
If sht.Name <> "目录汇总" Then sht.Delete
Next
Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFolderPicker) '调用打开对话框
If .Show = -1 Then
Set ff = fso.getfolder(.SelectedItems(1) & "\")
For Each fd In ff.subfolders
f = Dir(fd.Path & "\*.xl*")
Set wb = Workbooks.Open(fd.Path & "\" & f) '读取
For Each sht In wb.Worksheets
i = i + 1
sht.Copy after:=Workbooks("目录汇总.xlsm").Sheets("目录汇总")
ActiveSheet.Name = i
Next
wb.Close False
f = Dir
Next
End If
End With
Sheets("目录汇总").Select
MsgBox "数据导入成功！", 64, "提示！"
End Sub
Sub 超链接()
Dim i, sht As Worksheet
i = 1: [A2:C1000] = ""
For Each sht In Worksheets
If sht.Name <> "目录汇总" Then
i = i + 1
For j = 1 To 26
If sht.Cells(5, j) <> "" Then Cells(i, 1) = sht.Cells(5, j): Exit For
Next
For j = 26 To 1 Step -1
If sht.Cells(5, j) <> "" Then
Cells(i, 2) = sht.Cells(5, j)
If InStr(Cells(i, 2), "J") = 0 Then Cells(i, 2) = "/"
Exit For
End If
Next
Cells(i, 3) = sht.Name
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 3), Address:=ActiveWorkbook.Name, SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name
End If
Next
MsgBox "完成！！！", 64, "提示！"
End Sub
程序代码：
