Excel VBA：列出文件夹中的所有文件，包括超链接，并从找到的每个Excel文件复制数据

我在这里的第一篇帖子，所以要温柔：）

情况是这样的。作为一名软件测试人员，我正在从事一个大型软件项目。目前，我们正在着手对应用程序进行一次大规模的彻底检查，结果是产生了大量包含测试用例和状态报告的Excel文件（未来几个月将有200多个文件）。为了跟踪所有事情的进展，我们需要一个Excelsheet，它可以列出所有文件，包括超链接，并在每个文件存在时读取状态信息

我找到了大量关于列出文件夹中所有文件并为其提供超链接的教程。目前我正在使用此网站的代码：

因此，现在我可以从弹出屏幕中选择文件夹中的所有文件列表

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

选项比较文本
选项显式
函数以布尔形式排除（Ext为字符串）
'函数用途：从超链接列表中排除列出的文件扩展名
尺寸为X，长度为NumPos
'在此处输入/调整要从列表中排除的文件扩展名：
X=数组（“exe”、“bat”、“dll”、“zip”、“txt”、“xlsm”、“html”、“htm”、“xml”）
出错时继续下一步
NumPos=Application.WorksheetFunction.Match（Ext，X，0）
如果NumPos>0，则Excludes=True
错误转到0
端函数
子超链接文件列表（）
'宏用途：创建用户中所有文件的超链接列表
'指定的目录，包括文件大小和上次修改的日期
'注意：已添加（超链接对象的）TextToDisplay'属性
'在Excel 2000中。此代码测试Excel版本，不使用
'Texttodisplay属性（如果使用XL 97）。
将fso作为对象_
ShellApp作为对象_
文件作为对象_
子文件夹作为对象_
目录作为字符串_
问题是布尔型的_
优于整数
'关闭屏幕闪烁
Application.ScreenUpdating=False
“干净的床单
单元格。选择
选择。删除移位：=xlUp
范围（“A1”）。选择
'创建对象以获取目录中所有文件的列表
设置fso=CreateObject（“Scripting.FileSystemObject”）
'提示用户选择目录
做
问题=错误
设置ShellApp=CreateObject（“Shell.Application”）_
浏览文件夹（0，“请选择文件夹”，0，“D:）
'Browseforfolder（0，“请选择一个文件夹”，0，“D:\JBOSS\Testdossier”）
出错时继续下一步
'评估目录是否有效
Directory=ShellApp.self.Path
Set SubFolder=fso.GetFolder（Directory）.Files
如果错误号为0，则
如果MsgBox（“您没有选择有效的目录！”&vbCrLf&_
“您想再试一次吗？”，vbYesNoCancel_
“需要目录”）vbYes然后退出Sub
问题=正确
如果结束
错误转到0
循环直到问题=错误
'在工作表上设置标题
使用ActiveSheet
带.Range（“A1”）
.Value=“中所有文件的列表：”
.ColumnWidth=40
'如果是Excel 2000或更高版本，请添加带有文件名的超链接
"展示。如果更早，请添加显示完整路径的超链接
如果Val（Application.Version）>8，则“使用XL2000”+
.Parent.Hyperlinks.Add_
锚定：=.偏移量（0,1）_
地址：=目录_
TextToDisplay:=目录
Else使用XL97
.Parent.Hyperlinks.Add_
锚定：=.偏移量（0,1）_
地址：=目录
如果结束
以
带.Range（“A2”）
.Value=“文件名”
.Interior.ColorIndex=15
.ColumnWidth=50
带.Offset（0，1）
.ColumnWidth=15
.Value=“修改日期”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
带.Offset（0,2）
.ColumnWidth=12
.Value=“文件大小（Kb）”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
带.Offset（0,3）
.ColumnWidth=18
.Value=“状态测试档案”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
带.Offset（0,4）
.ColumnWidth=22
.Value=“Totaal aantal testgevallen”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
带.偏移量（0,5）
.ColumnWidth=15
.Value=“uidgevoerd”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
带.偏移量（0,6）
.ColumnWidth=15
.Value=“阿克库德”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
带.偏移量（0,7）
.ColumnWidth=6
.Value=“确定”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
带.Offset（0,8）
.ColumnWidth=6
.Value=“NOK”
.Interior.ColorIndex=15
.HorizontalAlignment=xlCenter
以
以
以
'将每个文件、详细信息和超链接添加到列表中
对于子文件夹中的每个文件
如果不排除（Right（File.Path，3））=True，则
使用ActiveSheet
'如果是Excel 2000或更高版本，请添加带有文件名的超链接
"展示。如果更早，请添加显示完整路径的超链接
如果Val（Application.Version）>8，则“使用XL2000”+
.超链接
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