Excel宏修改需求：批量读取Word文档数据并解决4605运行时错误

需求说明 #

• 将原宏修改为批量处理指定文件夹内所有.doc/.docx格式文件
• 修复运行时错误4605（提示：该方法或属性不可用，因为未选中任何文本），解决添加On Error Resume Next后无数据填充的问题

修改后的完整宏代码 #

Sub BatchImportFromWord()
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim fso As Object
    Dim targetFolder As Object
    Dim wordFile As Object
    Dim ws As Worksheet
    Dim currentRow As Long
    
    ' 初始化工作表，从第3行开始写入（和原宏保持一致）
    Set ws = ThisWorkbook.ActiveSheet
    currentRow = 3
    
    ' 创建Word应用实例
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    
    ' 创建文件系统对象，用于遍历文件夹
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 指定目标文件夹路径，请自行修改为实际路径
    Set targetFolder = fso.GetFolder("C:\Users\brendan.ramsey\OneDrive - Ofcom\Objectives\Brendan's Objectives 2022-23\Licence calls")
    
    ' 遍历文件夹内所有文件
    For Each wordFile In targetFolder.Files
        ' 只处理.doc和.docx格式
        If LCase(fso.GetExtensionName(wordFile.Path)) = "doc" Or LCase(fso.GetExtensionName(wordFile.Path)) = "docx" Then
            ' 尝试打开Word文档
            On Error Resume Next
            Set WordDoc = WordApp.Documents.Open(wordFile.Path)
            On Error GoTo 0
            
            If Not WordDoc Is Nothing Then
                ' 直接读取单元格文本，替换原Copy/Paste逻辑，避免4605错误
                ' 第1个表格第1行第3列 → Excel A列
                On Error Resume Next
                ws.Cells(currentRow, 1).Value = Trim(WordDoc.Tables(1).Cell(Row:=1, Column:=3).Range.Text)
                ' 移除Word单元格末尾的隐藏结束符
                ws.Cells(currentRow, 1).Value = Left(ws.Cells(currentRow, 1).Value, Len(ws.Cells(currentRow, 1).Value) - 2)
                On Error GoTo 0
                
                ' 第4个表格第3行第6列 → Excel B列
                On Error Resume Next
                ws.Cells(currentRow, 2).Value = Trim(WordDoc.Tables(4).Cell(Row:=3, Column:=6).Range.Text)
                ws.Cells(currentRow, 2).Value = Left(ws.Cells(currentRow, 2).Value, Len(ws.Cells(currentRow, 2).Value) - 2)
                On Error GoTo 0
                
                ' 第4个表格第3行第3列 → Excel C列
                On Error Resume Next
                ws.Cells(currentRow, 3).Value = Trim(WordDoc.Tables(4).Cell(Row:=3, Column:=3).Range.Text)
                ws.Cells(currentRow, 3).Value = Left(ws.Cells(currentRow, 3).Value, Len(ws.Cells(currentRow, 3).Value) - 2)
                On Error GoTo 0
                
                ' 第5个表格第2行第5列 → Excel D列
                On Error Resume Next
                ws.Cells(currentRow, 4).Value = Trim(WordDoc.Tables(5).Cell(Row:=2, Column:=5).Range.Text)
                ws.Cells(currentRow, 4).Value = Left(ws.Cells(currentRow, 4).Value, Len(ws.Cells(currentRow, 4).Value) - 2)
                On Error GoTo 0
                
                ' 第5个表格第2行第7列 → Excel E列
                On Error Resume Next
                ws.Cells(currentRow, 5).Value = Trim(WordDoc.Tables(5).Cell(Row:=2, Column:=7).Range.Text)
                ws.Cells(currentRow, 5).Value = Left(ws.Cells(currentRow, 5).Value, Len(ws.Cells(currentRow, 5).Value) - 2)
                On Error GoTo 0
                
                ' 第5个表格第2行第2列 → Excel F列
                On Error Resume Next
                ws.Cells(currentRow, 6).Value = Trim(WordDoc.Tables(5).Cell(Row:=2, Column:=2).Range.Text)
                ws.Cells(currentRow, 6).Value = Left(ws.Cells(currentRow, 6).Value, Len(ws.Cells(currentRow, 6).Value) - 2)
                On Error GoTo 0
                
                ' 关闭文档，不保存更改
                WordDoc.Close SaveChanges:=False
                Set WordDoc = Nothing
                
                ' 下一个文件写入下一行
                currentRow = currentRow + 1
            End If
        End If
    Next wordFile
    
    ' 清理资源
    WordApp.Quit
    Set WordApp = Nothing
    Set fso = Nothing
    Set targetFolder = Nothing
    
    MsgBox "批量处理完成！"
End Sub

关键修改说明 #

1. 批量处理实现：用Scripting.FileSystemObject遍历目标文件夹，自动筛选.doc/.docx文件，每个文件对应Excel的一行数据
2. 4605错误修复：
   • 抛弃原Copy/Paste逻辑，直接读取单元格Range.Text，避免因单元格为空或Copy操作触发的选中状态错误
   • 针对每个表格/单元格添加局部错误捕获，某个单元格读取失败不会影响其他数据写入
   • 移除全局On Error Resume Next，避免隐藏其他潜在问题
3. 细节优化：移除Word单元格文本末尾自带的两个隐藏字符（段落标记+单元格结束符），保证Excel中数据干净

注意事项 #

• 请务必修改代码中的目标文件夹路径为你实际需要处理的文件夹
• 若部分文档缺少指定的表格或单元格，对应Excel单元格会留空，不会中断整个批量任务

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