Exporting Tracked Changes and Comments to Excel

alzasp · #1 09-12-2018, 01:06 PM

Is there a macro I can use that exports the tracked changes, inserts and deletes, to excel? I have a macro (below) that exports the comments but it does not extract the tracked changes.

Code:

Sub CopyCommentsToExcel()
 'Create in Word vba
 Dim xlApp As Object
 Dim xlWB As Object
 Dim i As Integer
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err Then
         Set xlApp = CreateObject("Excel.Application")
     End If
     On Error GoTo 0
     xlApp.Visible = True
     Set xlWB = xlApp.Workbooks.Add        ' create a new workbook
     With xlWB.Worksheets(1)
     ' Create Heading
        HeadingRow = 1
        .Cells(HeadingRow, 1).Formula = "ITEM NO."
        .Cells(HeadingRow, 2).Formula = "PAGE"
        .Cells(HeadingRow, 3).Formula = "REVIEWER"
        .Cells(HeadingRow, 4).Formula = "COMMENT"
        .Cells(HeadingRow, 5).Formula = "DATE"
        
         For i = 1 To ActiveDocument.Comments.Count
             .Cells(i + HeadingRow, 1).Formula = ActiveDocument.Comments(i).Index
             .Cells(i + HeadingRow, 2).Formula = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
             .Cells(i + HeadingRow, 3).Formula = ActiveDocument.Comments(i).Author
             .Cells(i + HeadingRow, 4).Formula = ActiveDocument.Comments(i).Range
             .Cells(i + HeadingRow, 5).Formula = Format(ActiveDocument.Comments(i).Date, "dd/MM/yyyy")
             .Cells(i + HeadingRow, 6).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString
         Next i
     End With
     Set xlWB = Nothing
     Set xlApp = Nothing
 End Sub

macropod · #2 09-12-2018, 02:32 PM

The following Word macro exracts Track-Changes Data for all story ranges in the active document and sends them to a new Excel workbook. Field braces are replaced with ordinary braces and, if the revision is in a table cell, the cell address is reported in the form of '* A1 *'. Changes to Footnote & Endnote separators, continuation separators & continuation notices are ignored.

Code:

Sub ExportRevisions()
'Sourced from: https://www.msofficeforums.com/133132-post2.html
'Note: A VBA Reference to Excel is required, set via Tools|References in the Word VBE
Dim wdRng As Range, StrOut As String, StrTmp As String, i As Long, j As Long, SBar As Boolean
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
' Turn Off Screen Updating
Application.ScreenUpdating = False
StrOut = Replace("Folder|Document|Location|Author|Date & Time|Delete|Insert|From|To|Replace|Format|Other", "|", vbTab)
With ActiveDocument
  If .Revisions.Count = 0 Then MsgBox "There are no revisions (tracked changes) in this document. Exiting.", vbOKOnly: Exit Sub
  'Get Folder & Filname
  StrOut = StrOut & vbCr & .Path & vbTab & .Name
  For Each wdRng In .StoryRanges
    With wdRng
      ' Process the Revisions
      For i = 1 To .Revisions.Count
        StatusBar = "Analysing Revision " & i
        ' *****
          'Start a new line
          StrOut = StrOut & vbCr & vbTab & vbTab
          With .Revisions(i)
          'Get Location, Author & .Date
            Select Case wdRng.StoryType
              Case wdEvenPagesFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEvenPagesHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryHeaderStory" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Endnote: " & .Range.Endnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Footnote: " & .Range.Footnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdCommentsStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Comment: " & .Range.Comments(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnoteContinuationNoticeStory, wdEndnoteContinuationSeparatorStory, wdEndnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnoteContinuationNoticeStory, wdFootnoteContinuationSeparatorStory, wdFootnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdMainTextStory, wdTextFrameStory
                StrOut = StrOut & "Page: " & .Range.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & .Author & vbTab & .Date & vbTab
            End Select
            'Get Revision Type & Scope
            Select Case .Type
              Case wdRevisionDelete
                StrOut = StrOut & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionInsert
                StrOut = StrOut & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedFrom
                StrOut = StrOut & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedTo
                StrOut = StrOut & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionReplace
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionProperty, wdRevisionStyle, wdRevisionParagraphProperty 'Formatting
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case Else
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Other"
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
            End Select
          End With
        ' *****
      Next
    End With
  Next
End With
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
With xlApp
  .Visible = True
  .DisplayStatusBar = True
  .ScreenUpdating = False
  Set xlWkBk = .Workbooks.Add
  ' Update the workbook.
  With xlWkBk.Worksheets(1)
    For i = 0 To UBound(Split(StrOut, vbCr))
      xlApp.StatusBar = "Exporting Revision " & i
      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
    .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:L").AutoFit
    For i = 6 To 12
      .Columns(i).ColumnWidth = 80
    Next
    .Rows.AutoFit
  End With
  .StatusBar = False
  .DisplayStatusBar = SBar
  .ScreenUpdating = True
  ' Tell the user we're done.
  MsgBox "Workbook updates finished.", vbOKOnly
End With
' Release object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
' Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = SBar
' Restore Screen Updating
Application.ScreenUpdating = True
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

To limit processing to just the body of the document, delete:

Code:

  For Each wdRng In .StoryRanges
    With wdRng

and the corresponding:

Code:

    End With
  Next

To extract Word document revisions in a whole folder and, optionally, its subfolders and send them to an Excel workbook, you might use the following Excel macro:

Code:

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

Sub GetDocumentRevisions()
'Sourced from: https://www.msofficeforums.com/133132-post2.html
'Note: A VBA Reference to Word is required, via Tools|References in the VBE
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|Delete|Insert|From|To|Replace|Format|Other", "|", 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 ExportRevisions(wdApp, CStr(Split(StrFlds, vbCr)(i)))
  Next
Else
  Call ExportRevisions(wdApp, strTpFldr)
End If
wdApp.Quit: Set wdApp = Nothing
If SheetExists("Revisions") = True Then
  Set xlSht = Sheets("Revisions")
Else
  Set xlSht = Sheets.Add
  xlSht.Name = "Revisions"
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:L").AutoFit
  For i = 6 To 12
    .Columns(i).ColumnWidth = 80
  Next
  .Rows.AutoFit
End With
Application.StatusBar = False
MsgBox "Revisions export complete.", vbOKOnly
Application.ScreenUpdating = True
End Sub

Sub ExportRevisions(wdApp As Word.Application, StrFld As String)
Dim strDoc As String, strFls, wdDoc As Word.Document, wdRng As Word.Range, i As Long
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 Each wdRng In .StoryRanges
      With wdRng
        For i = 1 To .Revisions.Count
          If i Mod 100 = 0 Then DoEvents
          'Start a new line
          StrOut = StrOut & vbCr & vbTab & vbTab
          With .Revisions(i)
          'Get Location, Author & .Date
            Select Case wdRng.StoryType
              Case wdEvenPagesFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEvenPagesHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryHeaderStory" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Endnote: " & .Range.Endnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Footnote: " & .Range.Footnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdCommentsStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Comment: " & .Range.Comments(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnoteContinuationNoticeStory, wdEndnoteContinuationSeparatorStory, wdEndnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnoteContinuationNoticeStory, wdFootnoteContinuationSeparatorStory, wdFootnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdMainTextStory, wdTextFrameStory
                StrOut = StrOut & "Page: " & .Range.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & .Author & vbTab & .Date & vbTab
            End Select
            'Get Revision Type & Scope
            Select Case .Type
              Case wdRevisionDelete
                StrOut = StrOut & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionInsert
                StrOut = StrOut & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedFrom
                StrOut = StrOut & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedTo
                StrOut = StrOut & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionReplace
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionProperty, wdRevisionStyle, wdRevisionParagraphProperty 'Formatting
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case Else
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Other"
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
            End Select
          End With
        Next
      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

alzasp · #3 09-13-2018, 05:22 AM

When I run the macro I get this error and it highlights the red bold code below. Any thoughts on how the fix this?

"Compile error: "User-defined type not defined"

Code:

Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook

macropod · #4 09-13-2018, 02:40 PM

Did you read the Note one the second line of the code and do as advised?

earnold517 · #5 11-13-2018, 10:41 AM

Hello, this is a wonderful code. I am new to learning how to do all the VBA tricks and have a few questions.

I also found a code the at extracts the comments as well but the extracting of the paragraph header and title doesn't work. Similar to the first example in this thread.

And one for the changes in the images. I would like to have all these functions in one code.

The goal is I have multiple users contribution to a master document that goes through an update every year and instead of gathering change suggestions comments in excel, then manually making the changes in word, I'd like for the contributors to make the changes, and provide comments directly in word and then i can pull the author, tracked changes, image changes, comments and there specific location out to a tracker. Then with minor manipulation of the tracker i could have it submitted as a formal document of changes to the revision of the document.

Thank you again for any help.

macropod · #6 11-13-2018, 01:34 PM

The following Word macro exports comments in the active document to a new Excel workbook. The output includes the Comment: Number, Page; Related Heading # & Heading text (if they exist); Line #, Author; Date & Time; Comment Text; Reference Text; Parent Comment; and whether the comment has been marked as resolved (this feature depends on the document's compatibility status). Where replies to comments have been recorded, ‘Ditto’ is output for the text commented on.

As for:

Quote:

Originally Posted by earnold517

And one for the changes in the images. I would like to have all these functions in one code.

image changes could only be reported if changed via track changes and, as you'll see from the output from the macro below, the kinds of details one would want from revisions and comments are quite different. I'd be reluctant to try to generate the lot in a single report.

Code:

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

To extract Word document comments in a whole folder and, optionally, its subfolders and send them to an Excel workbook, you might use the following Excel macro. In addition to the data output by the single-document macro, the output includes the document's Folder & name

Code:

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

Note that there are slight differences in the kinds of data output by the two macros. That should give you some ideas about how you could edit the code to vary the outputs per your own requirements.

macropod · #7 12-29-2018, 10:04 PM

Cross-posted at: Exract Tracked Changes from Word to Excel
For cross-posting etiquette, please read: Excelguru Help Site - A message to forum cross posters

eokwaro · #8 02-03-2021, 01:08 PM

How do i select the reference

'Note: A VBA Reference to Excel is required, via Tools|References

Guessed · #9 11-28-2021, 09:41 PM

The exact library name will vary according the version of Excel you have loaded on your machine. In the VBA editor you need to go to Tools > References and find the library with a name like "Microsoft Excel xx.x Object Library" where xx.x will be a version number.

zakn · #10 01-18-2022, 05:51 AM

The vba in Post #2 from Paul Edstein works like a charm.

Thanks for the assistance.

husk · #11 06-14-2022, 02:13 AM

Works great. Thank You!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Convert specific author's name in comments and tracked changes to another name	rmk911	Word VBA	2	12-09-2021 09:14 PM
Tracked changes and comments disappeared with All Markup selected	sleake	Word	4	06-18-2018 05:12 AM
Word for Mac 2011 - Lost all tracked changes and all comments	Clint57	Word	1	08-24-2017 06:56 PM
Merging certain Tracked Changes and Comments	The_Chefkoch	Word	0	02-01-2017 07:22 AM
Restrict editing: allowing forms, tracked changes AND comments	andylaw31	Word	1	08-14-2015 03:13 PM