批量提取文件夹内所有Word文档注释到Excel的VBA报错如何解决

报错原因梳理 #

原代码存在以下核心逻辑错误，导致触发运行时报错、无法批量遍历：

• 同时声明sFileName和vFile两个变量调用Dir函数遍历文件，遍历逻辑冲突，无法正常获取下一个文件路径
• Excel写入行号未动态累加，处理新文件时会直接覆盖上一个文件的注释内容
• xlApp、oDoc等核心对象未提前声明，未定义对象触发错误91
• 写入普通文本内容时误用.Formula属性，特殊内容会触发无效参数错误5
• 代码末尾多余重新创建Excel对象的逻辑，会直接清空已写入的注释内容

修复后可正常运行的代码 #

以下代码建议在Word的VBA编辑器中运行，运行前将sFilePath修改为你的目标文件夹路径即可：

Option Explicit
'需提前在工具-引用中勾选"Microsoft Excel xx.x Object Library"，或改为后期绑定
Private Sub LoopThroughWordFiles()
    '变量声明
    Dim sFilePath As String
    Dim sFileName As String
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim oDoc As Document
    Dim i As Integer, HeadingRow As Integer, xlRow As Integer
    Dim myRange As Range
    Dim strSection As String
    
    '配置目标文件夹路径
    sFilePath = "C:\CommentTest"
    If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
    
    '初始化Excel工作簿
    Set xlApp = New Excel.Application
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    HeadingRow = 1
    xlRow = HeadingRow
    
    '写入表头
    With xlWB.Worksheets(1)
        .Cells(HeadingRow, 1).Value = "文件名称"
        .Cells(HeadingRow, 2).Value = "注释编号"
        .Cells(HeadingRow, 3).Value = "页码"
        .Cells(HeadingRow, 4).Value = "所属章节"
        .Cells(HeadingRow, 5).Value = "注释内容"
        .Cells(HeadingRow, 6).Value = "评论人缩写"
        .Cells(HeadingRow, 7).Value = "评论日期"
    End With
    
    '遍历文件夹下所有Word文档
    sFileName = Dir(sFilePath & "*.doc*")
    Do While sFileName <> ""
        Set oDoc = Documents.Open(Filename:=sFilePath & sFileName, Visible:=False)
        
        '遍历当前文档所有注释
        For i = 1 To oDoc.Comments.Count
            xlRow = xlRow + 1
            Set myRange = oDoc.Comments(i).Scope
            strSection = ParentLevel(myRange.Paragraphs(1))
            
            With xlWB.Worksheets(1)
                .Cells(xlRow, 1).Value = sFileName
                .Cells(xlRow, 2).Value = oDoc.Comments(i).Index
                .Cells(xlRow, 3).Value = oDoc.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
                .Cells(xlRow, 4).Value = strSection
                .Cells(xlRow, 5).Value = oDoc.Comments(i).Range.Text
                .Cells(xlRow, 6).Value = oDoc.Comments(i).Initial
                .Cells(xlRow, 7).Value = Format(oDoc.Comments(i).Date, "MM/dd/yyyy")
            End With
        Next i
        
        '关闭当前文档，释放对象
        oDoc.Close SaveChanges:=False
        Set oDoc = Nothing
        '获取下一个文件
        sFileName = Dir
    Loop
    
    '释放Excel对象
    Set xlWB = Nothing
    Set xlApp = Nothing
    MsgBox "注释导出完成！"
End Sub

Function ParentLevel(Para As Word.Paragraph) As String
    Dim sStyle As Variant
    Dim strTitle As String
    Dim ParaAbove As Word.Paragraph
    Set ParaAbove = Para
    sStyle = Para.Range.ParagraphStyle
    sStyle = Left(sStyle, 4)
    If sStyle = "Head" Then
        GoTo Skip
    End If
    Do While ParaAbove.OutlineLevel = Para.OutlineLevel
        Set ParaAbove = ParaAbove.Previous
    Loop
Skip:
    strTitle = ParaAbove.Range.Text
    strTitle = Left(strTitle, Len(strTitle) - 1)
    ParentLevel = ParaAbove.Range.ListFormat.ListString & " " & strTitle
End Function

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