Code to export Word track changes to Excel

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

* Please try a lower page number.

* Please enter only numbers.

* Please try a lower page number.

* Please enter only numbers.

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.

Stefan Blom
Word MVP
Volunteer Moderator
~~~~
Note that MVPs do not work for Microsoft
MVP program info: https://mvp.microsoft.com/
MS Community FAQ: https://answers.microsoft.com/en-us/page/faq
~~~~

3 people were helped by this reply

·

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

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

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

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.

Cheers
Paul Edstein
(Fmr MS MVP - Word)

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

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

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

The code, as posted in the other thread works correctly as is. If you're only getting a deletions output, that suggests there are no tracked additions, etc. That may be because only the deletions have been tracked or because the additions etc. have been accepted. In either of those cases, there's nothing more to export. Either that or you've copied the later code I posted in the same thread for exporting comments...
Cheers
Paul Edstein
(Fmr MS MVP - Word)

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Hi Paul,

I inserted additional text and deleted some text with tracked changes turned on just to make sure. The inserted text appears in the same column as does the deleted text. Each change (deletion/insertion) shows up as a completed sentence--not indicating exactly what changed in the sentence. That is why I wanted to show green for inserts and red for deletions. If I am unable to convert inserts into a separate column, then the different colors would help. The code I am using from one of your previous posts, see below:

Dim Rng As Range

Dim StrRev As String

Dim StrTmp As String

Dim i As Long

Dim j As Long

    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

    With xlWB.Worksheets(1)

' 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 = "Analyzing 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)

              'Add color Red for Deletion

              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)

              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)

              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)

              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)

              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)

              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

 

iNumChanges = ActiveDocument.Revisions.Count

vChange = ActiveDocument.Revisions(1).Type

 

End With

End Sub

Function TidyText(Rng As Range)

With Rng.Duplicate

.Start = .Sentences.First.Start

.End = .Sentences.Last.End

TidyText = Replace(Replace(Replace(Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<CR>"), Chr(11), "<LF>"), Chr(19), "{"), Chr(21), "}")

End With

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

 

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

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

Cheers
Paul Edstein
(Fmr MS MVP - Word)

2 people were helped by this reply

·

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Yes, the corrected code you sent does work.  I really appreciate your assistance with this task. I do have another question though. If I record a macro while formatting the Excel file, could I copy that code into the same code that exports the tracked changes? If so, exactly where should I place it so it runs right after the content has been exported?

Thanks in advance,

Alethea Haynes

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Try inserting the code before the End With in the following section of the code that Paul gave you:

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

If that doesn't work, let us know what formatting changes you want to make and show the code created by recording the macro.

Hope this helps,
Doug Robbins - MVP Office Apps & Services (Word)
dougrobbinsmvp@gmail.com
Screen shots by Snagit from www.techsmith.com

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

You could indeed supplement the existing code with more code for your desired formatting. Such code might be inserted after:

.Columns("A:C").AutoFit

or you could call another macro containing the additional formatting code from the same place. The macro recorder isn't noted for producing good code; it's incapable of producing anything like the code I've posted and what it does produce is generally verbose and clumsy.

Cheers
Paul Edstein
(Fmr MS MVP - Word)

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

* Please try a lower page number.

* Please enter only numbers.

* Please try a lower page number.

* Please enter only numbers.

 
 

Question Info


Last updated September 28, 2020 Views 1,504 Applies to: