Excel VBA批量提取文件夹文件指定单元格数据至活动表

我正在编写VBA代码，需求是遍历指定文件夹并列出所有文件，再从每个结构相同的文件的工作表中复制指定单元格数据，写入活动表对应文件名所在行。目前代码已完成文件遍历及文件名、修改日期的列出，但无法提取单元格数据。尝试的代码无效，推测需要打开文件、引用工作表后复制指定单元格区域，但不知具体实现方法。

现有代码如下：

Sub UpdateLog()
    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)

    'Declare the variables
    Dim objFSO As FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim strPath As String
    Dim strFile As String
    Dim NextRow As Long

    'Specify the path to the folder
    strPath = "C:\Users\julia\Forms"

    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'Get the folder
    Set objFolder = objFSO.GetFolder(strPath)

    'If the folder does not contain files, exit the sub
    If objFolder.Files.Count = 0 Then
        MsgBox "未找到任何文件...", vbExclamation
        Exit Sub
    End If

    'Turn off screen updating
    Application.ScreenUpdating = False

    'Find the next available row
    NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 4

    'Loop through each file in the folder
    For Each objFile In objFolder.Files

        'List the name and date/time of the current file
        Cells(NextRow, 2).Value = objFile.Name
        Cells(NextRow, 3).Value = objFile.DateLastModified

此处需添加从各文件提取数据至活动表的代码

我尝试使用：Cells(NextRow, 4).Value = objFile.Worksheet("Front Sheet").Range("E6").Copy，但该代码无效。我知道需要打开文件、引用工作表后复制指定单元格区域，可能用到CopyRange和Destination Range，但不知具体实现方法。

NextRow = NextRow + 1

    Next objFile

    'Change the width of the columns to achieve the best fit
    'Columns.AutoFit

    'Turn screen updating back on
    Application.ScreenUpdating = True
    
End Sub

错误原因说明 #

你之前的代码无效是因为objFile是FileSystemObject的文件对象，它仅能获取文件的基础属性（如名称、修改日期），无法直接访问Excel文件内部的工作表和单元格。必须先通过Excel对象打开目标工作簿，才能操作其中的内容。

修正后的完整代码 #

以下是添加了数据提取逻辑的完整代码，包含错误处理（避免因文件损坏、工作表不存在导致崩溃），并优化了性能：

Sub UpdateLog()
    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)

    'Declare the variables
    Dim objFSO As FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim strPath As String
    Dim NextRow As Long
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim srcWS As Worksheet
    
    '指定源文件夹路径
    strPath = "C:\Users\julia\Forms"
    
    '设置活动工作表（确保写入到正确的表）
    Set targetWS = ActiveSheet

    '创建FileSystemObject实例
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    '获取目标文件夹
    Set objFolder = objFSO.GetFolder(strPath)

    '如果文件夹为空则退出
    If objFolder.Files.Count = 0 Then
        MsgBox "未找到任何文件...", vbExclamation
        Exit Sub
    End If

    '关闭屏幕更新提升性能
    Application.ScreenUpdating = False
    '关闭显示警报（如覆盖提示）
    Application.DisplayAlerts = False

    '找到下一个可用行
    NextRow = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 4

    '遍历文件夹中的每个文件
    For Each objFile In objFolder.Files
        '仅处理Excel文件（可根据需要扩展格式）
        If objFSO.GetExtensionName(objFile.Path) Like "xls*" Then
            '写入文件名和修改日期
            targetWS.Cells(NextRow, 2).Value = objFile.Name
            targetWS.Cells(NextRow, 3).Value = objFile.DateLastModified
            
            On Error Resume Next '启用错误捕获
            '打开目标工作簿（后台打开，不显示）
            Set targetWB = Workbooks.Open(objFile.Path, ReadOnly:=True)
            If Err.Number = 0 Then '打开成功
                '引用目标工作表
                Set srcWS = targetWB.Worksheets("Front Sheet")
                If Not srcWS Is Nothing Then '工作表存在
                    '方法1：直接读取单元格值（比Copy更高效）
                    targetWS.Cells(NextRow, 4).Value = srcWS.Range("E6").Value
                    '如果需要复制格式，用方法2：
                    'srcWS.Range("E6").Copy Destination:=targetWS.Cells(NextRow, 4)
                Else
                    targetWS.Cells(NextRow, 4).Value = "工作表不存在"
                End If
                '关闭工作簿，不保存
                targetWB.Close SaveChanges:=False
            Else
                targetWS.Cells(NextRow, 4).Value = "文件无法打开"
            End If
            On Error GoTo 0 '关闭错误捕获
        Else
            '非Excel文件，标记说明
            targetWS.Cells(NextRow, 2).Value = objFile.Name
            targetWS.Cells(NextRow, 3).Value = objFile.DateLastModified
            targetWS.Cells(NextRow, 4).Value = "非Excel文件"
        End If
        
        NextRow = NextRow + 1
    Next objFile

    '自动调整列宽
    targetWS.Columns.AutoFit

    '恢复屏幕更新和警报显示
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "数据更新完成！", vbInformation
End Sub

关键优化点说明 #

1. 仅处理Excel文件：通过GetExtensionName过滤文件格式，避免处理非Excel文件导致错误。
2. 后台只读打开：使用ReadOnly:=True打开文件，避免占用文件锁，同时提升速度。
3. 错误处理：添加On Error Resume Next捕获文件打开失败、工作表不存在的情况，确保代码不会崩溃。
4. 两种数据复制方式：
   • 直接读取值：性能更高，仅复制内容，适合不需要格式的场景。
   • 使用Copy方法：可同时复制单元格格式，适合需要保留格式的场景。
5. 明确引用工作表：通过targetWS指定写入的活动工作表，避免因切换工作表导致写入错误。

内容的提问来源于stack exchange，提问作者Julia Linney