Possible to export Word track changes information to Excel spreadsheet

Here is the full code, now debugged, so works perfectly. It creates a new document listing tracked changes in a document (though not formatting changes or footnotes). You are welcome to use it:

Sub ExtractTrackChanges()

'

' ExtractTrackChanges Macro

'

    '=========================

    'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com

    'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.

    'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.

    '=========================

    'The macro creates a new document

    'and extracts insertions and deletions

    'marked as tracked changes from the active document

    'NOTE: Other types of changes are skipped

    '(e.g. formatting changes or inserted/deleted footnotes and endnotes)

    'Only insertions and deletions in the main body of the document will be extracted

    'The document will also include metadata

    'Inserted text will be applied black font color

    'Deleted text will be applied red font color

    'Minor adjustments are made to the styles used

    'You may need to change the style settings and table layout to fit your needs

    '=========================

    Dim oDoc As Document

    Dim oNewDoc As Document

    Dim oTable As Table

    Dim oRow As Row

    Dim oCol As Column

    Dim oRange As Range

    Dim oRevision As Revision

    Dim strText As String

    Dim n As Long

    Dim i As Long

    Dim Title As String

    Title = "Extract Tracked Changes to New Document"

    n = 0 'use to count extracted changes

    Set oDoc = ActiveDocument

    If oDoc.Revisions.Count = 0 Then

        MsgBox "The active document contains no tracked changes.", vbOKOnly, Title

        GoTo ExitHere

    Else

        'Stop if user does not click Yes

        If MsgBox("Do  you want to extract tracked changes to a new document?" & vbCr & vbCr & _

                "NOTE: Only insertions and deletions will be included. " & _

                "All other types of changes will be skipped.", _

                vbYesNo + vbQuestion, Title) <> vbYes Then

            GoTo ExitHere

        End If

    End If

    Application.ScreenUpdating = False

    'Create a new document for the tracked changes, base on Normal.dot

    Set oNewDoc = Documents.Add

    'Set to landscape

    oNewDoc.PageSetup.Orientation = wdOrientLandscape

    With oNewDoc

        'Make sure any content is deleted

        .Content = ""

        'Set appropriate margins

        With .PageSetup

            .LeftMargin = CentimetersToPoints(2)

            .RightMargin = CentimetersToPoints(2)

            .TopMargin = CentimetersToPoints(2.5)

        End With

        'Insert a 7-column table for the tracked changes and metadata

            Set oTable = .Tables.Add _

            (Range:=Selection.Range, _

            numrows:=1, _

            NumColumns:=7)

    End With

    'Insert info in header - change date format as you wish

    oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _

        "Tracked changes extracted from: " & oDoc.FullName & vbCr & _

        "Created by: " & Application.UserName & vbCr & _

        "Creation date: " & Format(Date, "MMMM d, yyyy")

    'Adjust the Normal style and Header style

    With oNewDoc.Styles(wdStyleNormal)

        With .Font

            .Name = "Arial"

            .Size = 9

            .Bold = False

        End With

        With .ParagraphFormat

            .LeftIndent = 0

            .SpaceAfter = 3

        End With

    End With

    With oNewDoc.Styles(wdStyleHeader)

        .Font.Size = 8

        .ParagraphFormat.SpaceAfter = 0

    End With

    'Format the table appropriately

    With oTable

        .Range.Style = wdStyleNormal

        .AllowAutoFit = False

        .PreferredWidthType = wdPreferredWidthPercent

        .PreferredWidth = 100

        For Each oCol In .Columns

            oCol.PreferredWidthType = wdPreferredWidthPercent

        Next oCol

        .Columns(1).PreferredWidth = 5  'Page

        .Columns(2).PreferredWidth = 5  'Line

        .Columns(3).PreferredWidth = 10 'Type of change

        .Columns(4).PreferredWidth = 35 'Inserted/deleted text

        .Columns(5).PreferredWidth = 15 'Author

        .Columns(6).PreferredWidth = 10 'Revision date

        .Columns(7).PreferredWidth = 10 'Revision date

    End With

    'Insert table headings

    With oTable.Rows(1)

        .Cells(1).Range.Text = "Page"

        .Cells(2).Range.Text = "Line"

        .Cells(3).Range.Text = "Type"

        .Cells(4).Range.Text = "What has been inserted or deleted"

        .Cells(5).Range.Text = "Author"

        .Cells(6).Range.Text = "Date"

        .Cells(7).Range.Text = "Time"

    End With

    'Get info from each tracked change (insertion/deletion) from oDoc and insert in table

    For Each oRevision In oDoc.Revisions

        Select Case oRevision.Type

            'Only include insertions and deletions

            Case wdRevisionInsert, wdRevisionDelete

                'In case of footnote/endnote references (appear as Chr(2)),

                'insert "[footnote reference]"/"[endnote reference]"

                With oRevision

                    'Get the changed text

                    strText = .Range.Text

                    Set oRange = .Range

                    Do While InStr(1, oRange.Text, Chr(2)) > 0

                        'Find each Chr(2) in strText and replace by appropriate text

                        i = InStr(1, strText, Chr(2))

                        If oRange.Footnotes.Count = 1 Then

                            strText = Replace(Expression:=strText, _

                                    Find:=Chr(2), Replace:="[footnote reference]", _

                                    Start:=1, Count:=1)

                            'To keep track of replace, adjust oRange to start after i

                            oRange.Start = oRange.Start + i

                        ElseIf oRange.Endnotes.Count = 1 Then

                            strText = Replace(Expression:=strText, _

                                    Find:=Chr(2), Replace:="[endnote reference]", _

                                    Start:=1, Count:=1)

                            'To keep track of replace, adjust oRange to start after i

                            oRange.Start = oRange.Start + i

                        End If

                   Loop

                End With

                'Add 1 to counter

                n = n + 1

                'Add row to table

                Set oRow = oTable.Rows.Add

                'Insert data in cells in oRow

                With oRow

                    'Page number

                    .Cells(1).Range.Text = _

                        oRevision.Range.Information(wdActiveEndPageNumber)

                    'Line number - start of revision

                    .Cells(2).Range.Text = _

                        oRevision.Range.Information(wdFirstCharacterLineNumber)

                    'Type of revision

                    If oRevision.Type = wdRevisionInsert Then

                        .Cells(3).Range.Text = "Inserted"

                        'Apply automatic color (black on white)

                        oRow.Range.Font.Color = wdColorAutomatic

                    Else

                        .Cells(3).Range.Text = "Deleted"

                        'Apply red color

                        oRow.Range.Font.Color = wdColorRed

                    End If

                    'The inserted/deleted text

                    .Cells(4).Range.Text = strText

                    'The author

                    .Cells(5).Range.Text = oRevision.Author

                    'The revision date

                    .Cells(6).Range.Text = Format(oRevision.Date, "dd-mm-yyyy")

                    'The revision date

                    .Cells(7).Range.Text = Format(oRevision.Date, "HH:MM")

                End With

        End Select

    Next oRevision

    'If no insertions/deletions were found, show message and close oNewDoc

    If n = 0 Then

        MsgBox "No insertions or deletions were found.", vbOKOnly, Title

        oNewDoc.Close savechanges:=wdDoNotSaveChanges

        GoTo ExitHere

    End If

    'Apply bold formatting and heading format to row 1

    With oTable.Rows(1)

        .Range.Font.Bold = True

        .HeadingFormat = True

    End With

    Application.ScreenUpdating = True

    Application.ScreenRefresh

    oNewDoc.Activate

    MsgBox n & " tracked changed have been extracted. " & _

        "Finished creating document.", vbOKOnly, Title

ExitHere:

    Set oDoc = Nothing

    Set oNewDoc = Nothing

    Set oTable = Nothing

    Set oRow = Nothing

    Set oRange = Nothing

End Sub

Since the original objective was to export the data to an Excel workbook, try:

Sub ExportRevisions()

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

Dim Rng As Range, StrRev As String, StrTmp As String, i As Long, j As Long

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

' Store current Status Bar status, then switch on

SBar = Application.DisplayStatusBar

Application.DisplayStatusBar = True

' Turn Off Screen Updating

Application.ScreenUpdating = False

StrRev = "Location,Author,Date & Time,Delete,Insert,From,To,Replace,Style,Other"

StrRev = Replace(StrRev, ",", vbTab)

With ActiveDocument

  For Each Rng In .StoryRanges

    With Rng

      ' Process the Revisions

      For i = 1 To .Revisions.Count

        StatusBar = "Analysing Revision " & i

        If i Mod 100 = 0 Then DoEvents

        With .Revisions(i)

          Select Case Rng.StoryType

            Case wdEvenPagesFooterStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                " EvenPagesFooter" & vbTab & .Author & vbTab & .Date & vbTab

            Case wdFirstPageFooterStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                " FirstPageFooter" & vbTab & .Author & vbTab & .Date & vbTab

            Case wdPrimaryFooterStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                " PrimaryFooter" & vbTab & .Author & vbTab & .Date & vbTab

            Case wdEvenPagesHeaderStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                " EvenPagesHeader" & vbTab & .Author & vbTab & .Date & vbTab

            Case wdFirstPageHeaderStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                " FirstPageHeader" & vbTab & .Author & vbTab & .Date & vbTab

            Case wdPrimaryHeaderStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                " PrimaryHeaderStory" & vbTab & .Author & vbTab & .Date & vbTab

            Case wdEndnotesStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                "Endnote: " & .Range.Endnotes(1).Reference.Text & vbTab & .Author & vbTab & .Date & vbTab

            Case wdFootnotesStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                "Footnote: " & .Range.Footnotes(1).Reference.Text & vbTab & .Author & vbTab & .Date & vbTab

            Case wdCommentsStory

              StrRev = StrRev & vbCr & "Section " & .Range.Sections(1).Index & _

                "Comment: " & .Range.Comments(1).Index & vbTab & .Author & vbTab & .Date & vbTab

            Case wdEndnoteContinuationNoticeStory, wdEndnoteContinuationSeparatorStory, wdEndnoteSeparatorStory

              StrRev = StrRev & vbCr & vbTab & .Author & vbTab & .Date & vbTab

            Case wdFootnoteContinuationNoticeStory, wdFootnoteContinuationSeparatorStory, wdFootnoteSeparatorStory

              StrRev = StrRev & vbCr & vbTab & .Author & vbTab & .Date & vbTab

            Case wdMainTextStory, wdTextFrameStory

              StrRev = StrRev & vbCr & "Page: " & .Range.Information(wdActiveEndAdjustedPageNumber) & vbTab & .Author & vbTab & .Date & vbTab

          End Select

          Select Case .Type

            Case wdRevisionDelete

              StrRev = StrRev & TidyText(.Range.Text)

              With .Range

                If .Information(wdWithInTable) Then StrRev = StrRev & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"

              End With

            Case wdRevisionInsert

              StrRev = StrRev & TidyText(.Range.Text)

              With .Range

                If .Information(wdWithInTable) Then StrRev = StrRev & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"

              End With

            Case wdRevisionMovedFrom

              StrRev = StrRev & TidyText(.Range.Text)

              With .Range

                If .Information(wdWithInTable) Then StrRev = StrRev & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"

              End With

            Case wdRevisionMovedTo

              StrRev = StrRev & TidyText(.Range.Text)

              With .Range

                If .Information(wdWithInTable) Then StrRev = StrRev & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"

              End With

            Case wdRevisionReplace

              StrRev = StrRev & TidyText(.Range.Text)

              With .Range

                If .Information(wdWithInTable) Then StrRev = StrRev & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"

              End With

            Case wdRevisionStyle

              StrRev = StrRev & TidyText(.Range.Text)

              With .Range

                If .Information(wdWithInTable) Then StrRev = StrRev & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"

              End With

            Case Else

              StrRev = StrRev & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Other"

              With .Range

                If .Information(wdWithInTable) Then StrRev = StrRev & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"

              End With

          End Select

        End With

      Next

    End With

  Next

End With

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(StrRev, vbCr))

      xlApp.StatusBar = "Exporting Revision " & i

      StrTmp = Split(StrRev, vbCr)(i)

        For j = 0 To UBound(Split(StrTmp, vbTab))

          .Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)

        Next

    Next

    .Columns("A:C").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, "<TAB>"), vbCr, "<CR>"), Chr(11), "<LF>"), 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

Tabs are output as <TAB>, manual line breaks are output as <LF> and paragraph breaks are output as <CR>. 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; otherwise the code processes all StoryRanges in the document. To limit processing to just the body of the document, you could just delete:

  For Each Rng In .StoryRanges

    With Rng

and the corresponding:

    End With

  Next

This is useful but I would like the data to include the time of revisions, not just the date. I did try altering the macro from doctools: I added the extra column but couldn't work out the right code for the time.