求助excel 工作簿目录和打开该文件超链接

rendiule01 · 发表于 2023-2-18 11:02

求助弹出文件夹对话框，选择文件夹，自动生成如下红色部分（手工录入的）VBA，由于办事处文件夹很多，而且文件夹内的独立工作薄也很多，

客户.zip (186.42 KB, 下载次数: 3)

rendiule01 · 发表于 2023-2-18 12:10

vba大佬相助

我是小黑屋 · 发表于 2023-2-18 15:06

Sub GetExcelFiles()
Dim selectedFolder As String
selectedFolder = GetFolder()
If selectedFolder = "" Then Exit Sub
Dim folderPath As String
folderPath = selectedFolder & ""
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim fileIndex As Long
If lastRow > 1 Then
fileIndex = ws.Cells(lastRow, "A").Value + 1
End If
Dim file As Object
Dim fileName As String
Dim filePath As String
Dim linkAddress As String
For Each file In fso.GetFolder(folderPath).Files
If LCase(Right(file.Name, 4)) = ".xls" Or LCase(Right(file.Name, 5)) = ".xlsx" Then
fileName = file.Name
filePath = file.Path
linkAddress = "=HYPERLINK(""" & filePath & """, """ & fileName & """)"
ws.Cells(lastRow + 1, "A").Value = fileIndex
ws.Cells(lastRow + 1, "B").Value = fileName
ws.Cells(lastRow + 1, "C").Value = folderPath
ws.Cells(lastRow + 1, "D").Formula = linkAddress
lastRow = lastRow + 1
fileIndex = fileIndex + 1
End If
Next file
MsgBox "已完成获取 " & fileIndex - 1 & " 个工作簿文件名的操作。"
End Sub
Function GetFolder()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择一个文件夹"
.Show
If .SelectedItems.Count > 0 Then
GetFolder = .SelectedItems(1)
End If
End With
End Function

复制代码

我是小黑屋 · 发表于 2023-2-18 15:07

目录表.zip (20.7 KB, 下载次数: 8)
详见附件

		自动登录	找回密码
密码			免费注册

[求助] 求助excel 工作簿目录和打开该文件超链接