VBA脚本遍历Word文档提取分数至Excel失效无报错求助

问题背景 #

需求：遍历指定目录下的所有Word文档，提取文档中分数并追加到Excel工作簿。
异常情况：此前脚本运行时能打印文件名，异常终止后，当前脚本无任何反应且未抛出错误。

原代码问题分析 #

1. Dir函数使用错误：首次调用Dir仅指定目录未加文件筛选（如*.docx），且StrFile = Dir放在循环开头，导致跳过第一个文件；异常终止后Dir状态未重置，后续调用返回空值，循环直接结束。
2. 文件路径缺失：打开Word文档时仅用文件名StrFile，未拼接完整目录路径，导致系统找不到文件，脚本静默失败。
3. 变量声明与资源泄漏：Word应用实例、文档对象在循环内重复声明创建，每次循环都会新建Word进程，未关闭释放，导致内存泄漏引发无响应。
4. 无错误捕获机制：遇到文件损坏、查找失败等异常时直接终止，无任何提示，无法定位问题。
5. Excel操作不明确：依赖ActiveWorkbook/ActiveSheet，未明确指定目标工作簿和工作表，容易引发操作错误。

修复后的完整代码 #

Sub DataExtraction()
    Dim StrFile As String
    Dim wdApp As Word.Application
    Dim wDoc As Word.Document
    Dim wRng As Word.Range
    Dim rngTest As Word.Range
    Dim rngEnd As Word.Range
    Dim LastRow As Long
    Dim targetWs As Worksheet
    Dim docPath As String
    
    ' 指定目标目录和文件筛选
    docPath = "C:\Users\lones\Desktop\Business Documents\"
    StrFile = Dir(docPath & "*.docx") ' 仅遍历Word文档
    
    ' 初始化Word应用（循环外创建，避免重复实例）
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = New Word.Application
    End If
    On Error GoTo ErrorHandler
    wdApp.Visible = False ' 后台运行提升效率
    
    ' 明确指定目标工作表
    Set targetWs = ThisWorkbook.Worksheets("Sheet1") ' 替换为你的工作表名
    
    Do While Len(StrFile) > 0
        Debug.Print "处理文件：" & StrFile
        ' 打开Word文档（拼接完整路径）
        Set wDoc = wdApp.Documents.Open(Filename:=docPath & StrFile, ReadOnly:=True, AddToRecentfiles:=False)
        
        ' 查找分数所在区域
        Set rngTest = wDoc.Range
        If rngTest.Find.Execute(FindText:="Test description... This user had ") Then
            Set rngEnd = wDoc.Range(rngTest.End, wDoc.Range.End)
            If rngEnd.Find.Execute(FindText:=" correct answers") Then
                Set wRng = wDoc.Range(rngTest.End, rngEnd.Start)
                ' 获取分数并写入Excel，避免复制粘贴
                LastRow = targetWs.Cells(targetWs.Rows.Count, 1).End(xlUp).Row + 1
                targetWs.Cells(LastRow, 1).Value = Trim(wRng.Text)
            End If
        End If
        
        ' 关闭文档，释放对象
        wDoc.Close SaveChanges:=False
        Set wDoc = Nothing
        
        ' 获取下一个文件
        StrFile = Dir
    Loop
    
    ' 关闭Word应用，释放资源
    wdApp.Quit
    Set wdApp = Nothing
    MsgBox "数据提取完成！"
    Exit Sub

ErrorHandler:
    ' 错误处理，记录失败信息
    LastRow = targetWs.Cells(targetWs.Rows.Count, 1).End(xlUp).Row + 1
    targetWs.Cells(LastRow, 1).Value = "处理文件 " & StrFile & " 失败：" & Err.Description
    ' 清理当前文档和对象
    If Not wDoc Is Nothing Then
        wDoc.Close SaveChanges:=False
        Set wDoc = Nothing
    End If
    StrFile = Dir ' 继续处理下一个文件
    Resume Next
End Sub

关键修复说明 #

• Dir函数重置：指定*.docx筛选Word文件，拼接完整路径确保能找到文件，异常后通过Dir继续遍历。
• 资源优化：循环外创建单个Word实例，循环内关闭文档并释放对象，避免内存泄漏。
• 错误捕获：新增错误处理分支，记录失败文件和错误信息，不中断整体遍历。
• Excel操作优化：明确指定目标工作表，直接写入文本替代复制粘贴，提升稳定性和效率。
• 静默运行：Word后台运行（Visible=False），避免弹窗干扰，提升运行速度。

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