Code to export Word track changes to Excel

Question

I am interested in code to extract track changes (deletions red, insertions green). I want to show page, change, author, date & time, and whether insert or deletion.

Please assist.

Thanks,

Alethea Haynes

Answer 1

It seems a whole lot of & vbTab sequences have been deleted from the code in the linked thread.

As for:

Each change (deletion/insertion) shows up as a completed sentence--not indicating exactly what changed in the sentence

that will only be so if the tracked change is to an entire sentence.

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 & vbTab & 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 & vbTab & vbTab & 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 & vbTab & vbTab & vbTab & 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 & vbTab & vbTab & vbTab & vbTab & 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 & vbTab & vbTab & vbTab & vbTab & vbTab & 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

Answer 2

You can make use of the option to print a list of markup. In Word, click File | Print; click the drop down under Settings and choose List of Markup. You can then print the document to PDF.

Answer 3

Good morning,

I did try the code from the above link you provided. The code did export track changes to Excel, but for some reason all the changes were in the delete column. The other columns following the delete column were empty.

Can you provide the fix / paste corrected code in this forum?

Thanks,

Alethea

Answer 4

See my post 3 November 2014 of in: https://answers.microsoft.com/en-us/office/forum/office_2007-word/possible-to-export-word-track-changes-information/e0dee9dc-aedb-41d3-92bf-8dc609cc75af

Instead of colour-coding each, they're output to separate columns.

Answer 5

Thank you so very much for responding. I am aware of the Print Settings providing selection in dropdown to print a list of document markups. It does not provide the results I currently need.

I have code now, but it requires some adjustments in order to change my deletions "red" and my insertions "green".

Thanks,

Alethea