VBA批量提取多Word文档带格式内容写入Excel的代码报错求助

• 实现目标：批量将指定文件夹下的数百份Word文档导入至单个Excel工作表，规则如下：
  • 每个Word文档对应一组独立单元格
  • 文档名称存入指定单元格，文档全量内容存入相邻单元格，保留原有文本格式
• 业务背景：企业新内网迁移工具仅支持读取Excel工作簿数据，需完成存量文档的格式适配。

你提供的两段VBA代码存在以下明确错误，是导致运行失败的直接原因：

第一段代码核心问题 #

• 循环判断条件存在非法字符：Do While FileName ⋖⋗ "" 中的符号为全角特殊字符，正确写法应为Do While FileName <> ""
• 完全缺失文件名写入逻辑，未实现文档名同步写入相邻单元格的需求
• 命名范围引用逻辑错误：你在名称管理器定义的LastRow未绑定明确的父工作表，跨表运行时会出现定位偏差；且xlPasteValues参数仅粘贴无格式纯文本，无法保留Word原有格式
• Word实例销毁时机错误：在循环内部执行NewWordFile.Quit，处理完第一个文档后Word进程就被关闭，后续文档打开操作必然报错
• 未做文件类型过滤：Dir(FolderName)会枚举文件夹下所有类型文件，打开非Word格式文件时会触发运行时错误

第二段代码核心问题 #

• 变量命名冲突：将变量命名为Range，与VBA内置的Range对象重名，会导致对象识别混乱
• 赋值逻辑错误：ImportPolicyfromWord.Cells(i, 1).Value = objDoc 是将Word文档对象直接赋值给单元格，无法输出文件名；objDoc.Range.PasteSpecial是Word侧的方法，将其返回值直接赋值给单元格Value属性不符合语法规范，是触发「运行时错误'424'：需要对象」的核心原因
• 资源泄漏：打开的Word文档从未执行Close操作，运行后会在后台残留大量WINWORD.EXE进程
• 无错误兜底逻辑，运行中途报错时Word进程无法自动退出，会持续占用文件锁

运行前操作：打开VBA编辑器，依次点击「工具」-「引用」，勾选Microsoft Word [对应版本号] Object Library即可；如需使用无引用的晚绑定模式，无需修改代码，直接运行即可。

Sub BatchImportWordToExcel()
    Dim ws As Worksheet
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim folderPath As String
    Dim fileName As String
    Dim i As Long
    
    ' ==== 按需修改以下配置参数 ====
    folderPath = "C:\Users\jdodd\Documents\Cleaned\" ' Word文件存放路径，末尾必须带反斜杠
    Set ws = ThisWorkbook.Worksheets("ImportPolicyfromWord") ' 目标工作表名称
    ' 横向排列配置（文件名在A列、内容在B列，每行一个文档）
    i = 1 ' 从第2行开始写入，第1行留作表头
    ' ============================
    
    ' 初始化运行环境
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Set wordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wordApp = CreateObject("Word.Application")
        Err.Clear
    End If
    On Error GoTo ErrorHandler
    wordApp.Visible = False
    
    ' 写入表头
    ws.Cells(1, 1).Value = "文档名称"
    ws.Cells(1, 2).Value = "文档内容"
    
    ' 枚举所有docx文件，如需兼容doc格式将*.docx改为*.doc*即可
    fileName = Dir(folderPath & "*.docx")
    Do While fileName <> ""
        i = i + 1
        ' 写入文件名到A列
        ws.Cells(i, 1).Value = fileName
        ' 只读方式打开Word文档，不加入最近文件列表
        Set wordDoc = wordApp.Documents.Open( _
            FileName:=folderPath & fileName, _
            ReadOnly:=True, _
            AddToRecentFiles:=False)
        ' 复制全文档内容
        wordDoc.Range.Copy
        ' 粘贴到B列对应单元格，保留富文本格式；如需嵌入可编辑Word对象，将Format参数值改为"Microsoft Word 文档对象"
        ws.Cells(i, 2).PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
        ' 关闭当前文档，不保存更改
        wordDoc.Close SaveChanges:=False
        Set wordDoc = Nothing
        ' 枚举下一个文件
        fileName = Dir()
    Loop
    
    ' 自动调整列宽
    ws.Columns("A:B").AutoFit

CleanExit:
    ' 清理资源，避免后台残留进程
    Application.CutCopyMode = False
    If Not wordDoc Is Nothing Then
        wordDoc.Close SaveChanges:=False
        Set wordDoc = Nothing
    End If
    If Not wordApp Is Nothing Then
        wordApp.Quit SaveChanges:=False
        Set wordApp = Nothing
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "导入完成，共处理 " & i - 1 & " 份文档", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "运行出错，错误信息：" & Err.Description, vbCritical
    Resume CleanExit
End Sub

• 如需要按照你举例的纵向排列模式（文件名写入A1、内容写入A2，第二个文件名写入A3、内容写入A4，以此类推），只需修改代码中单元格写入逻辑：将i初始值设为0，每次循环步长改为i = i + 2，文件名写入ws.Cells(i, 1)，内容粘贴到ws.Cells(i + 1, 1)即可
• 如果不需要保留格式，仅需提取纯文本，可将粘贴行代码替换为ws.Cells(i, 2).Value = wordDoc.Range.Text，运行速度会大幅提升
• Excel单个单元格最多支持存储32767个字符，超过长度的文档内容会被自动截断
• 如运行时提示文件找不到，优先检查文件夹路径末尾是否添加了反斜杠

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