求助：多Word文件转Excel的VBA代码仅运行无输出问题

编写了一段用于将多个Word文件数据复制到Excel的VBA代码，运行时仅显示执行状态，未出现报错，但没有任何数据复制到Excel中，恳请帮忙排查问题。代码如下：

Sub Copy_Data_From_Multiple_WordFiles()

Dim FolderName As String
Dim FileName As String
Dim NewWordFile As New Word.Application
Dim NewDoc As New Word.Document

Application.DisplayAlerts = False
'Application.ScreenUpdating = False

FolderName = "C:\Users\1040804\Desktop\BCS Data Check\"
FileName = Dir(FolderName)

'Loop start

Do While FileName <> ""

    Set NewDoc = NewWordFile.documents.Open(FolderName & FileName)
    
    NewDoc.Range(0, NewDoc.Range.End).Copy
    Range("LastRow").PasteSpecial xlPasteValues
    
    NewDoc.Close SaveChanges:=wdDoNotSaveChanges
    NewWordFile.Quit
    
FileName = Dir()

Loop

End Sub

问题根源分析 #

• Word进程提前终止：第一次循环就执行NewWordFile.Quit，导致后续循环无法打开新文档，且剪贴板数据可能因Word进程关闭失效。
• 粘贴目标未定义：Excel中没有默认的LastRow命名区域，代码无法确定粘贴位置。
• 未筛选Word文件：Dir(FolderName)会返回文件夹内所有类型文件，非Word文档会导致无效操作。
• 对象声明不合理：Dim NewDoc As New Word.Document在循环外声明，可能导致对象残留问题。

修正后的代码 #

Sub Copy_Data_From_Multiple_WordFiles()
    Dim FolderName As String
    Dim FileName As String
    Dim NewWordFile As Word.Application
    Dim NewDoc As Word.Document
    Dim ws As Worksheet
    Dim lastRow As Long
    
    ' 指定目标工作表，可根据需求修改为Sheet1等具体工作表
    Set ws = ActiveSheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    FolderName = "C:\Users\1040804\Desktop\BCS Data Check\"
    ' 仅筛选.doc和.docx格式的Word文件
    FileName = Dir(FolderName & "*.doc*")
    
    ' 初始化Word应用并隐藏窗口
    Set NewWordFile = New Word.Application
    NewWordFile.Visible = False
    
    Do While FileName <> ""
        ' 打开目标Word文档
        Set NewDoc = NewWordFile.Documents.Open(FolderName & FileName)
        
        ' 复制Word全文内容
        NewDoc.Range.Copy
        
        ' 计算Excel中最后一行，确定粘贴起始位置
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        If lastRow = 1 And ws.Cells(1, 1).Value = "" Then
            ws.Range("A1").PasteSpecial xlPasteValues
        Else
            ws.Cells(lastRow + 1, 1).PasteSpecial xlPasteValues
        End If
        
        ' 关闭文档并释放对象
        NewDoc.Close SaveChanges:=wdDoNotSaveChanges
        Set NewDoc = Nothing
        
        ' 获取下一个Word文件
        FileName = Dir()
    Loop
    
    ' 退出Word应用并释放对象
    NewWordFile.Quit
    Set NewWordFile = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "数据复制完成！"
End Sub

注意事项 #

• 需在VBA编辑器中引用Microsoft Word Object Library：打开VBA编辑器（Alt+F11）→ 工具→引用→勾选对应版本的Microsoft Word Object Library。
• 确认目标文件夹路径正确，且存在合法的Word文档。
• 若需保留Word中的格式，可将xlPasteValues替换为xlPasteAll或其他粘贴类型。

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