Microsoft Office Forums - View Single Post - [Solved] Exporting Tracked Changes and Comments to Excel

macropod · 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 document's Folder & name and, for the comment, it's: Location; Author; Date & Time; Related Heading # & Heading text (if they exist); Comment Text; Reference Text; 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:

Code:

Option Explicit
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.