VBA Tracked Changes HELP

Hi guys,

I need your help here...

i'm trying to create a VBA code to pull trakced changes from a document and display it in a newly created document.

Does anyone know how i need to change this code so that it also picks up the insertions and deletions form header and footer of the document.

the below code will extract only the insertions and deletions of main body but i've tried a few edits and nothing seems to work

Thanks guys


------code-----

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 6-column table for the tracked changes and metadata
        Set oTable = .Tables.Add _
            (Range:=Selection.Range, _
            numrows:=1, _
            NumColumns:=6)
    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 = 6
        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 = 55 'Inserted/deleted text
        .Columns(5).PreferredWidth = 15 'Author
        .Columns(6).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"
    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, "mm-dd-yyyy")
                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

------------------

A fairly simple approach is to delete everything that isn't a revision from the activedocument, then save it to a new document:

Sub Demo()
Dim Sctn As Section, HdFt As HeaderFooter
Dim Rng As Range, Rev As Revision
With ActiveDocument
  .TrackRevisions = False
  Set Rng = .Range(0, 0)
  For Each Rev In .Revisions
    Rng.End = Rev.Range.Start
    Rng.Text = vbNullString
    Set Rng = Rev.Range
    Rng.Collapse wdCollapseEnd
  Next
  Rng.End = .Range.End
  Rng.Text = vbNullString
  For Each Sctn In .Sections
    For Each HdFt In Sctn.Headers
      With HdFt
        Set Rng = .Range
        For Each Rev In HdFt.Range.Revisions
          Rng.End = Rev.Range.Start
          Rng.Text = vbNullString
          Set Rng = Rev.Range
          Rng.Collapse wdCollapseEnd
        Next
        Rng.End = .Range.End
        Rng.Text = vbNullString
      End With
      For Each HdFt In Sctn.Footers
        With HdFt
          Set Rng = .Range
          For Each Rev In HdFt.Range.Revisions
            Rng.End = Rev.Range.Start
            Rng.Text = vbNullString
            Set Rng = Rev.Range
            Rng.Collapse wdCollapseEnd
          Next
          Rng.End = .Range.End
          Rng.Text = vbNullString
      End With
    Next
  Next
End With
End Sub

Note: the above code doesn't actually do the save part.

Your initial post Asked:

Does anyone know how i need to change this code so that it also picks up the insertions and deletions form header and footer of the document.

The code I posted works fine for that.

You latest post still refers to footers when, in fact, the issue is with footnotes and endnotes. It would be helpful if you were rather more precise about the terminology you use. Asking for help with one problem, then complaining the help provided doesn't work for something you didn't ask for help with isn't going to win you any friends.

Footnote and endnote extraction poses quite a different problem, especially when it comes to how you might extract their tracked change content when their references are not themselves part of a tracked change (eg only a few words in a footnote have been changed, but the text to which the reference is attached hasn't been changed). If you can clarify your expectations in that regard, progress might be made.

Have you actually tried the code I posted - as I posted it?

i tried to fix the problem with your code, if i mark one of the FOR LOOP statement as comment then the code works fine... however this code will delete everything that isn't a revision from the 'activedocument... but i need a code that will extract all the revisions from header and footer to a new document.

see below code... i have marked comment one of the for loop [line number - 16]...

Sub Demo()
Dim Sctn As Section, HdFt As HeaderFooter
Dim Rng As Range, Rev As Revision
With ActiveDocument
  .TrackRevisions = False
  Set Rng = .Range(0, 0)
  For Each Rev In .Revisions
    Rng.End = Rev.Range.Start
    Rng.Text = vbNullString
    Set Rng = Rev.Range
    Rng.Collapse wdCollapseEnd
  Next
  Rng.End = .Range.End
  Rng.Text = vbNullString
  For Each Sctn In .Sections
    'For Each HdFt In Sctn.Headers
      With HdFt
        Set Rng = .Range
        For Each Rev In HdFt.Range.Revisions
          Rng.End = Rev.Range.Start
          Rng.Text = vbNullString
          Set Rng = Rev.Range
          Rng.Collapse wdCollapseEnd
        Next
        Rng.End = .Range.End
        Rng.Text = vbNullString
      End With
      For Each HdFt In Sctn.Footers
        With HdFt
          Set Rng = .Range
          For Each Rev In HdFt.Range.Revisions
            Rng.End = Rev.Range.Start
            Rng.Text = vbNullString
            Set Rng = Rev.Range
            Rng.Collapse wdCollapseEnd
          Next
          Rng.End = .Range.End
          Rng.Text = vbNullString
      End With
    Next
  Next
End With
End Sub

Somehow a 'Next' went missing before 'For Each HdFt In Sctn.Footers'. Fix that and the code should work just fine.

Cross-posted at: http://www.vbaexpress.com/forum/showthread.php?t=45648
For cross-posting etiquette, please read FORUM RULE 8: http://www.excelforum.com/forum-rule...rum-rules.html