Excel VBA：制作一个文件夹中所有文件的列表，包括超链接和从它find的每个Excel文件中复制数据

我的第一篇文章，所以要温柔:)

这是情况。 我正在做一个大型的软件项目作为一个软件testing工具。 目前，我们已经开始对应用程序进行大幅度的改革，这些应用程序在很多带有testing用例和状态报告的Excel文件（未来几个月超过200个文件）中都会产生结果。 为了跟踪所有我们需要的Excelsheet的进度，可以列出所有文件，包括超链接，并在每个文件存在时读取状态信息。

我已经find了大量的教程，使一个文件夹中的所有文件的列表，并给他们超链接。 目前我使用的是这个网站的代码： http : //www.vbaexpress.com/kb/getarticle.php?kb_id=232

所以现在我可以制作一个我可以从popup屏幕中select的文件夹中的所有文件的列表。

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文件中复制信息。 我认为它必须在下面的部分几乎在底部“”添加每个文件，细节和超链接到列表“在最后”与“我试图从文件中的数据到目前为止我已经拿出什么:(我想要获取的数据是在每个工作簿的第一个工作表上的几个字段中的一些数字。

我认为代码必须在“.Offset（0，4）”之后出现，但请帮助我！

Answer 1

这应该可以帮助你：

 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 

对于扩展filter，请检查您的旧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