我在这里发表的第一篇文章，请保持温和：）
情况如下。我正在开发一个大型软件项目作为软件测试人员。目前，我们正在对应用程序进行大规模的改造，这将导致大量Excel文件包含测试用例和状态报告（未来几个月将超过200个文件）。要跟踪所有内容的进度，我们需要一个Excel表格，它可以列出所有文件，包括超链接，并在每个文件存在时读取状态信息。
我发现了很多关于制作文件夹中所有文件列表并给出超链接的教程。目前我正在使用此网站上的代码：http://www.vbaexpress.com/kb/getarticle.php?kb_id=232
所以现在我可以列出我可以从弹出屏幕中选择的文件夹中的所有文件。
Option Compare Text
Option Explicit
Function Excludes(Ext As String) As Boolean
'Function purpose: To exclude listed file extensions from hyperlink listing
Dim X, NumPos As Long
'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip", "txt", "xlsm", "html", "htm", "xml")
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then Excludes = True
On Error GoTo 0
End Function
Sub HyperlinkFileList()
'Macro purpose: To create a hyperlinked list of all files in a user
'specified directory, including file size and date last modified
'NOTE: The 'TextToDisplay' property (of the Hyperlink object) was added
'in Excel 2000. This code tests the Excel version and does not use the
'Texttodisplay property if using XL 97.
Dim fso As Object, _
ShellApp As Object, _
File As Object, _
SubFolder As Object, _
Directory As String, _
Problem As Boolean, _
ExcelVer As Integer
'Turn off screen flashing
Application.ScreenUpdating = False
' Clear sheet
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
'Create objects to get a listing of all files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
Set ShellApp = CreateObject("Shell.Application"). _
Browseforfolder(0, "Please choose a folder", 0, "D:")
'Browseforfolder(0, "Please choose a folder", 0, "D:\JBOSS\Testdossier")
On Error Resume Next
'Evaluate if directory is valid
Directory = ShellApp.self.Path
Set SubFolder = fso.GetFolder(Directory).Files
If Err.Number <> 0 Then
If MsgBox("You did not choose a valid directory!" & vbCrLf & _
"Would you like to try again?", vbYesNoCancel, _
"Directory Required") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
'Set up the headers on the worksheet
With ActiveSheet
With .Range("A1")
.Value = "Listing of all files in:"
.ColumnWidth = 40
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory, _
TextToDisplay:=Directory
Else 'Using XL97
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory
End If
End With
With .Range("A2")
.Value = "File Name"
.Interior.ColorIndex = 15
.ColumnWidth = 50
With .Offset(0, 1)
.ColumnWidth = 15
.Value = "Date Modified"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 2)
.ColumnWidth = 12
.Value = "File Size (Kb)"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 3)
.ColumnWidth = 18
.Value = "Status testdossier"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 4)
.ColumnWidth = 22
.Value = "Totaal aantal testgevallen"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 5)
.ColumnWidth = 15
.Value = "Uitgevoerd"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 6)
.ColumnWidth = 15
.Value = "Akkoord"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 7)
.ColumnWidth = 6
.Value = "OK"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 8)
.ColumnWidth = 6
.Value = "NOK"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
End With
End With
'Adds each file, details and hyperlinks to the list
For Each File In SubFolder
If Not Excludes(Right(File.Path, 3)) = True Then
With ActiveSheet
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path, _
TextToDisplay:=File.Name
Else 'Using XL97
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path
End If
'Add date last modified, and size in KB
With .Range("A65536").End(xlUp)
.Offset(0, 1) = File.datelastModified
With .Offset(0, 2)
.Value = WorksheetFunction.Round(File.Size / 1024, 1)
.NumberFormat = "#,##0.0"
End With
End With
'Add Total From this file to current workbook
With .Range("A65536").End(xlUp)
.Offset(0, 4) =
End With
End With
End If
Next
End Sub
我有一些问题但是:( 第一，它不会排除我放在那里的所有文件扩展名...例如.bat不会被选中，但.txt和.xlsm会。不知道如何解决这个问题。
第二，我只是不知道如何从列出的excel文件中复制信息。我认为必须在接下来的部分进行，几乎在底部＆＃34;＆＃39;将每个文件，详细信息和超链接添加到列表中＆＃34; 在最后＆＃34;与＆＃34;我到目前为止试图从文件中获取数据我没有得到任何东西:(我试图获取的数据是每个第一张上的几个字段中的一些数字工作簿。
我认为代码必须在＆＃34; .Offset（0,4）＆＃34;之后。但请帮助我！
答案 0 :(得分：0)
这可以帮到你：
Option Compare Text
Option Explicit
Function Excludes(Ext As String) As Boolean
'Function purpose: To exclude listed file extensions from hyperlink listing
Dim X, NumPos As Long
'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip", "txt", "xlsm", "html", "htm", "xml")
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then
Excludes = True
Else
Excludes = False
End If
On Error GoTo 0
End Function
对于扩展名过滤器，请检查旧功能，但我很确定没有任何“假”返回，因为您没有在代码中设置它。
然后你必须打开工作簿才能真正从中获取数据：
Sub HyperlinkFileList()
'Macro purpose: To create a hyperlinked list of all files in a user
'specified directory, including file size and date last modified
'NOTE: The 'TextToDisplay' property (of the Hyperlink object) was added
'in Excel 2000. This code tests the Excel version and does not use the
'Texttodisplay property if using XL 97.
Dim fso As Object, _
ShellApp As Object, _
File As Object, _
SubFolder As Object, _
Directory As String, _
Problem As Boolean, _
ExcelVer As Integer, _
TotalD As String, _
Wb As Workbook, _
Ws As Worksheet
'Turn off screen flashing
Application.ScreenUpdating = False
' Clear sheet
Cells.Delete Shift:=xlUp
'Useless : Range("A1").Select
'Create objects to get a listing of all files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
Set ShellApp = CreateObject("Shell.Application"). _
Browseforfolder(0, "Please choose a folder", 0, "D:")
'Browseforfolder(0, "Please choose a folder", 0, "D:\JBOSS\Testdossier")
On Error Resume Next
'Evaluate if directory is valid
Directory = ShellApp.self.Path
Set SubFolder = fso.GetFolder(Directory).Files
If Err.Number <> 0 Then
If MsgBox("You did not choose a valid directory!" & vbCrLf & _
"Would you like to try again?", vbYesNoCancel, _
"Directory Required") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
'Set up the headers on the worksheet
With ActiveSheet
With .Range("A1")
.Value = "Listing of all files in:"
.ColumnWidth = 40
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory, _
TextToDisplay:=Directory
Else 'Using XL97
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory
End If
End With
With .Range("A2")
.Value = "File Name"
.Interior.ColorIndex = 15
.ColumnWidth = 50
With .Offset(0, 1)
.ColumnWidth = 15
.Value = "Date Modified"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 2)
.ColumnWidth = 12
.Value = "File Size (Kb)"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 3)
.ColumnWidth = 18
.Value = "Status testdossier"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 4)
.ColumnWidth = 22
.Value = "Totaal aantal testgevallen"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 5)
.ColumnWidth = 15
.Value = "Uitgevoerd"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 6)
.ColumnWidth = 15
.Value = "Akkoord"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 7)
.ColumnWidth = 6
.Value = "OK"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 8)
.ColumnWidth = 6
.Value = "NOK"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
End With
End With
'Adds each file, details and hyperlinks to the list
For Each File In SubFolder
If Not Excludes(Right(File.Path, 3)) = True Then
With ActiveSheet
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path, _
TextToDisplay:=File.Name
Else 'Using XL97
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path
End If
'Add date last modified, and size in KB
With .Range("A65536").End(xlUp)
.Offset(0, 1) = File.datelastModified
With .Offset(0, 2)
.Value = WorksheetFunction.Round(File.Size / 1024, 1)
.NumberFormat = "#,##0.0"
End With
End With
'Add Total From this file to current workbook
Set Wb = Workbooks.Open(File)
Set Ws = Wb.Sheets("Sheet1")
With .Range("A65536").End(xlUp)
.Offset(0, 4) = Ws.Range("A1")
End With
Wb.Close
Set Wb = Nothing
Set Ws = Nothing
End With
End If
Next File
'Turn back on screen updating
Application.ScreenUpdating = True
End Sub