Sub ExportComments()
'Sourced from: https://www.msofficeforums.com/133132-post6.html
' Note: A reference to the Microsoft Excel # Object Library is required, set via Tools|References in the Word VBE.
Dim wdDoc As Document, StrCmt As String, StrHd As String, StrTmp As String, i As Long, j As Long
StrCmt = "Index,Page,Heading #,Heading,Line,Author,Date & Time,Comment,Reference Text,Parent,Resolved"
StrCmt = Replace(StrCmt, ",", vbTab): Set wdDoc = ActiveDocument
With wdDoc
  If .Comments.Count = 0 Then
    MsgBox "There are no comments in this document. Exiting.", vbOKOnly: Exit Sub
  End If
  ' Process the Comments
  For i = 1 To .Comments.Count
    With .Comments(i)
      StrCmt = StrCmt & vbCr & i & vbTab & .Reference.Information(wdActiveEndAdjustedPageNumber) & vbTab
      StrHd = .Scope.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString
      StrCmt = StrCmt & StrHd & vbTab
      If StrHd <> "" Then
        StrCmt = StrCmt & Split(.Scope.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.Text, vbCr)(0) & vbTab
      Else
        StrCmt = StrCmt & vbTab
      End If
        If .Scope.Information(wdWithInTable) = True Then
          StrCmt = StrCmt & "Table: " & wdDoc.Range(0, .Scope.Start).Tables.Count & ", Cell: " & ColAddr(.Scope.Cells(1).ColumnIndex) & .Scope.Cells(1).RowIndex
        Else
          StrCmt = StrCmt & "Line: " & .Reference.Information(wdFirstCharacterLineNumber)
        End If
      StrCmt = StrCmt & vbTab & .Author & vbTab
      StrCmt = StrCmt & .Date & vbTab & Replace(Replace(.Range.Text, vbTab, " "), vbCr, "") & vbTab
      If StrTmp <> .Scope.Text Then
        StrCmt = StrCmt & Replace(Replace(.Scope.Text, vbTab, " "), vbCr, "") & vbTab
        StrTmp = .Scope.Text
      Else
        StrCmt = StrCmt & "     Ditto" & vbTab
      End If
      If Not .Ancestor Is Nothing Then
        StrCmt = StrCmt & .Ancestor.Index & vbTab
      Else
        StrCmt = StrCmt & vbTab
      End If
        StrCmt = StrCmt & .Done & vbTab
    End With
  Next
End With
'Exit Sub
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
With xlApp
  Set xlWkBk = .Workbooks.Add
  ' Update the workbook.
  With xlWkBk.Worksheets(1)
    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
    .UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
    .UsedRange.Replace What:="¤", Replacement:=ChrW(&H2192), LookAt:=xlPart, SearchOrder:=xlByRows
    .Columns("A:L").AutoFit
  End With
  ' Tell the user we're done.
  MsgBox "Workbook updates finished.", vbOKOnly
  ' Switch to the Excel workbook
  .Visible = True
End With
' Release object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
End Sub

Function TidyText(StrTxt As String)
TidyText = Replace(Replace(Replace(Replace(Replace(StrTxt, vbTab, "¤"), vbCr, "¶"), Chr(11), "¶"), Chr(19), "{"), Chr(21), "}")
End Function

Function ColAddr(i As Long) As String
If i > 26 Then
  ColAddr = Chr(64 + Int(i / 26)) & Chr(64 + (i Mod 26))
Else
  ColAddr = Chr(64 + i)
End If
End Function

Dim FSO As Object, objFldr As Object, StrFlds As String, StrOut As String

Sub GetDocumentComments()
'Sourced from: https://www.msofficeforums.com/133132-post6.html
Dim strTpFldr As String, vFldrs, vFldr, Rslt, i As Long, j As Long, StrTmp As String, xlSht As Worksheet
strTpFldr = GetFolder: If strTpFldr = "" Then Exit Sub
Rslt = MsgBox("Include Sub-Folders?", vbYesNo)
Dim wdApp As New Word.Application: wdApp.Visible = True: wdApp.WordBasic.DisableAutoMacros
StrOut = Replace("Folder|Document|Location|Author|Date & Time|Heading #|Heading|Comment|Reference Text|Marked Resolved", "|", vbTab)
If Rslt = vbYes Then
  StrFlds = vbCr & strTpFldr
  If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
  Set vFldrs = FSO.GetFolder(strTpFldr).SubFolders
  For Each vFldr In vFldrs
    RecurseWriteFolderName (vFldr)
  Next
  For i = 1 To UBound(Split(StrFlds, vbCr))
    Call ExportComments(wdApp, CStr(Split(StrFlds, vbCr)(i)))
  Next
Else
  Call ExportComments(wdApp, strTpFldr)
End If
wdApp.Quit: Set wdApp = Nothing
If SheetExists("Comments") = True Then
  Set xlSht = Sheets("Comments")
Else
  Set xlSht = Sheets.Add
  xlSht.Name = "Comments"
End If
With xlSht
  .UsedRange.ClearContents
  For i = 0 To UBound(Split(StrOut, vbCr))
    StrTmp = Split(StrOut, vbCr)(i)
    For j = 0 To UBound(Split(StrTmp, vbTab))
      .Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
    Next
  Next
  j = UBound(Split(StrOut, vbCr)) + 1
  .UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
  .UsedRange.Replace What:="¤", Replacement:=ChrW(&H2192), LookAt:=xlPart, SearchOrder:=xlByRows
  .UsedRange.HorizontalAlignment = xlGeneral
  .UsedRange.VerticalAlignment = xlTop
  .Columns("A:J").AutoFit
  For i = 7 To 9
    .Columns(i).ColumnWidth = 80
  Next
  .Rows.AutoFit
End With
Application.StatusBar = False
MsgBox "Comments export complete.", vbOKOnly
Application.ScreenUpdating = True
End Sub

Sub ExportComments(wdApp As Word.Application, StrFld As String)
Dim strDoc As String, i As Long, wdDoc As Word.Document, wdRng As Word.Range, StrTxt As String
strDoc = Dir(StrFld & "\*.docx", vbNormal)
Do While strDoc <> ""
  Excel.Application.StatusBar = "Processing: " & StrFld & "\" & strDoc
  Set wdDoc = wdApp.Documents.Open(Filename:=StrFld & "\" & strDoc, ReadOnly:=True, AddToRecentFiles:=False)
  With wdDoc
    'Get Folder & Filname
    StrOut = StrOut & vbCr & StrFld & vbTab & strDoc
    For i = 1 To .Comments.Count
      If i Mod 100 = 0 Then DoEvents
      'Start a new line
      StrOut = StrOut & vbCr & vbTab
      With .Comments(i)
        'Get Location, Author & .Date/Time
        StrOut = StrOut & vbTab & "Page: " & .Reference.Information(wdActiveEndAdjustedPageNumber)
        If .Scope.Information(wdWithInTable) = True Then
          StrOut = StrOut & "¶Table Cell: " & ColAddr(.Scope.Cells(1).ColumnIndex) & .Scope.Cells(1).RowIndex
        Else
          StrOut = StrOut & "¶" & "Line: " & .Reference.Information(wdFirstCharacterLineNumber)
        End If
        StrOut = StrOut & vbTab & .Author & vbTab & .Date
        'Get Related Heading
        Set wdRng = .Scope.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range
        If Not wdRng.Style.NameLocal Like "Heading #" Then
          StrOut = StrOut & vbTab & vbTab
        Else
          StrOut = StrOut & vbTab & wdRng.ListFormat.ListString & vbTab & Split(wdRng.Text, vbCr)(0)
        End If
        'Get Comment, Related Text & Status
        If .Ancestor Is Nothing Then
          StrOut = StrOut & vbTab & TidyText(.Scope.Text)
        Else
          StrOut = StrOut & vbTab & "Reply to: " & .Ancestor.Author
        End If
        StrOut = StrOut & vbTab & .Done
      End With
    Next
    .Close False
  End With
  strDoc = Dir()
Loop
Set wdRng = Nothing: Set wdDoc = Nothing
End Sub
 
Sub RecurseWriteFolderName(vFldr)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(vFldr).SubFolders
StrFlds = StrFlds & vbCr & CStr(vFldr)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub
 
Function GetFolder() As String
GetFolder = ""
Set objFldr = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not objFldr Is Nothing) Then GetFolder = objFldr.Items.Item.Path
Set objFldr = Nothing
End Function

Function SheetExists(SheetName As String) As Boolean
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then SheetExists = True
NoSuchSheet:
End Function

Function TidyText(StrTxt As String)
TidyText = Replace(Replace(Replace(Replace(Replace(StrTxt, vbTab, "¤"), vbCr, "¶"), Chr(11), "¶"), Chr(19), "{"), Chr(21), "}")
End Function

Function ColAddr(i As Long) As String
If i > 26 Then
  ColAddr = Chr(64 + Int(i / 26)) & Chr(64 + (i Mod 26))
Else
  ColAddr = Chr(64 + i)
End If
End Function