Extract comments from multiple word docs into Excel

Question

I'm trying to loop through all word documents in a folder and put all the comments for each file into an Excel workbook. When I run my code I get the following error "Run-time error '91' Object variable or With block Variable not set. The code only gets comments from the first file in the directory, then errors, it's not looping.

I've looked at numerous websites and found plenty of references for extracting comments into excel, but not for all word files in a directory.

https://answers.microsoft.com/en-us/msoffice/forum/all/export-word-review-comments-in-excel/54818c46-b7d2-416c-a4e3-3131ab68809c https://www.mrexcel.com/board/threads/extracting-comments-from-word-document-to-excel.1126759/

This website looked promising for what I need to do, but no one answered his question Extracting data from multiple word docs to single excel

I updated the code to open each word file, but I get the following error: Run-time error '5': Invalid procedure call or argument

It appears to open each word document but doesn't populate the excel sheet with the comments.

UPDATED CODE:

'VBA List all files in a folder using Dir
Private Sub LoopThroughWordFiles()
    
    'Variable Declaration
    Dim sFilePath As String
    Dim sFileName As String
    
    Dim i As Integer, HeadingRow As Integer
    Dim objPara As Paragraph
    Dim objComment As Comment
    Dim strSection As String
    Dim strTemp
    Dim myRange As Range
    
    'Specify File Path
    sFilePath = "C:\CommentTest"
    
    'Check for back slash
    If Right(sFilePath, 1) <> "\" Then
        sFilePath = sFilePath & "\"
    End If
    
    'Create an object for Excel.
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
 
'Create a workbook
Set xlWB = xlApp.Workbooks.Add
'Create Excel worksheet
With xlWB.Worksheets(1)
' Create Heading
    HeadingRow = 1
    .Cells(HeadingRow, 1).Formula = "File Name"
    .Cells(HeadingRow, 2).Formula = "Comment"
    .Cells(HeadingRow, 3).Formula = "Page"
    .Cells(HeadingRow, 4).Formula = "Paragraph"
    .Cells(HeadingRow, 5).Formula = "Comment"
    .Cells(HeadingRow, 6).Formula = "Reviewer"
    .Cells(HeadingRow, 7).Formula = "Date"

    strSection = "preamble" 'all sections before "1." will be labeled as "preamble"
    strTemp = "preamble"
    xlRow = 1
        
    sFileName = Dir(sFilePath)
    MsgBox ("sFileName: " + sFileName)
    MsgBox ("sFilePath: " + sFilePath)
    vFile = Dir(sFilePath & "*.*")

    Do While sFileName <> ""
        Set oDoc = Documents.Open(Filename:=sFilePath & vFile)
        
        For i = 1 To ActiveDocument.Comments.count
                        Set myRange = ActiveDocument.Comments(i).Scope
            strSection = ParentLevel(myRange.Paragraphs(1)) ' find the section heading for this comment
            'MsgBox strSection
            .Cells(i + HeadingRow, 1).Formula = ActiveDocument.Comments(i).Index
            .Cells(i + HeadingRow, 2).Formula = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
            .Cells(i + HeadingRow, 3).Value = strSection
            .Cells(i + HeadingRow, 4).Formula = ActiveDocument.Comments(i).Range
            .Cells(i + HeadingRow, 5).Formula = ActiveDocument.Comments(i).Initial
            .Cells(i + HeadingRow, 6).Formula = Format(ActiveDocument.Comments(i).Date, "MM/dd/yyyy")
            .Cells(i + HeadingRow, 7).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString
        Next i
        '- CLOSE WORD DOCUMENT

        oDoc.Close SaveChanges:=False
        vFile = Dir
        
        'Set the fileName to the next available file
        sFileName = Dir
    Loop
End With

Set xlApp = Nothing
Set xlApp = CreateObject("Excel.Application")

End Sub

Function ParentLevel(Para As Word.Paragraph) As String
'From Tony Jollans
' Finds the first outlined numbered paragraph above the given paragraph object
    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

Answer 1

This version of the Excel macro outputs all the document comments to the active worksheet(starting at row 1), with the filenames in column A.

Sub ImportComments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrCmt As String, StrTmp As String, i As Long, j As Long
StrCmt = Replace("File,Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date", ",", vbTab)
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.DisplayAlerts = False: wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
  With wdDoc
    If .Comments.Count > 0 Then
      ' Process the Comments
      For i = 1 To .Comments.Count
        StrCmt = StrCmt & vbCr & Split(strFolder, ".doc")(0) & vbTab
        With .Comments(i)
          StrCmt = StrCmt & .Reference.Information(wdActiveEndAdjustedPageNumber) & _
            vbTab & .Author & vbTab & .Date & vbTab
          With .Scope.Paragraphs(1).Range
            StrCmt = StrCmt & _
              .GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString & vbTab
            With .Duplicate
              .End = .End - 1
              StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab
            End With
          End With
          With .Range.Duplicate
            .End = .End - 1
            StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")
          End With
        End With
      Next
      ' Update the worksheet
      With ActiveSheet
        .Columns("E").NumberFormat = "@"
        For i = 0 To UBound(Split(StrCmt, vbCr))
          StrTmp = Split(StrCmt, vbCr)(i)
          For j = 0 To UBound(Split(StrTmp, vbTab))
            .Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
          Next
        Next
        .Columns("A:M").AutoFit: .Columns("D:E").ColumnWidth = 25
      End With
    End If
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
wdApp.Quit
' Tell the user we're done.
MsgBox "Finished.", vbOKOnly
' Release object memory
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function