![]() |
#2
约定的童话2022-10-13 23:13
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 |
请各位VB高手写个代码,该代码可以读取某文件夹里面指定含有关键字的文件名,是xlsx类型的,不显示后缀名 按最新文件日期显示在窗口里的头条,并且用鼠标点击该文件名就可以打开该文件!谢谢!