Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Closed Thread
 
Thread Tools Display Modes
  #1  
Old 09-12-2018, 01:06 PM
alzasp alzasp is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2016
Novice
Exporting Tracked Changes and Comments to Excel
 
Join Date: Sep 2018
Posts: 2
alzasp is on a distinguished road
Default Exporting Tracked Changes and Comments to Excel


Is there a macro I can use that exports the tracked changes, inserts and deletes, to excel? I have a macro (below) that exports the comments but it does not extract the tracked changes.

Code:
Sub CopyCommentsToExcel()
 'Create in Word vba
 Dim xlApp As Object
 Dim xlWB As Object
 Dim i As Integer
     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        ' create a new workbook
     With xlWB.Worksheets(1)
     ' Create Heading
        HeadingRow = 1
        .Cells(HeadingRow, 1).Formula = "ITEM NO."
        .Cells(HeadingRow, 2).Formula = "PAGE"
        .Cells(HeadingRow, 3).Formula = "REVIEWER"
        .Cells(HeadingRow, 4).Formula = "COMMENT"
        .Cells(HeadingRow, 5).Formula = "DATE"
        
         For i = 1 To ActiveDocument.Comments.Count
             .Cells(i + HeadingRow, 1).Formula = ActiveDocument.Comments(i).Index
             .Cells(i + HeadingRow, 2).Formula = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
             .Cells(i + HeadingRow, 3).Formula = ActiveDocument.Comments(i).Author
             .Cells(i + HeadingRow, 4).Formula = ActiveDocument.Comments(i).Range
             .Cells(i + HeadingRow, 5).Formula = Format(ActiveDocument.Comments(i).Date, "dd/MM/yyyy")
             .Cells(i + HeadingRow, 6).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString
         Next i
     End With
     Set xlWB = Nothing
     Set xlApp = Nothing
 End Sub

Last edited by macropod; 09-12-2018 at 02:27 PM. Reason: Added code tags & formatting
  #2  
Old 09-12-2018, 02:32 PM
macropod's Avatar
macropod macropod is offline Exporting Tracked Changes and Comments to Excel Windows 7 64bit Exporting Tracked Changes and Comments to Excel Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

The following Word macro exracts Track-Changes Data for all story ranges in the active document and sends them to a new Excel workbook. 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.
Code:
Sub ExportRevisions()
'Sourced from: https://www.msofficeforums.com/133132-post2.html
'Note: A VBA Reference to Excel is required, set via Tools|References in the Word VBE
Dim wdRng As Range, StrOut As String, StrTmp As String, i As Long, j As Long, SBar As Boolean
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
' Turn Off Screen Updating
Application.ScreenUpdating = False
StrOut = Replace("Folder|Document|Location|Author|Date & Time|Delete|Insert|From|To|Replace|Format|Other", "|", vbTab)
With ActiveDocument
  If .Revisions.Count = 0 Then MsgBox "There are no revisions (tracked changes) in this document. Exiting.", vbOKOnly: Exit Sub
  'Get Folder & Filname
  StrOut = StrOut & vbCr & .Path & vbTab & .Name
  For Each wdRng In .StoryRanges
    With wdRng
      ' Process the Revisions
      For i = 1 To .Revisions.Count
        StatusBar = "Analysing Revision " & i
        ' *****
          'Start a new line
          StrOut = StrOut & vbCr & vbTab & vbTab
          With .Revisions(i)
          'Get Location, Author & .Date
            Select Case wdRng.StoryType
              Case wdEvenPagesFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEvenPagesHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryHeaderStory" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Endnote: " & .Range.Endnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Footnote: " & .Range.Footnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdCommentsStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Comment: " & .Range.Comments(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnoteContinuationNoticeStory, wdEndnoteContinuationSeparatorStory, wdEndnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnoteContinuationNoticeStory, wdFootnoteContinuationSeparatorStory, wdFootnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdMainTextStory, wdTextFrameStory
                StrOut = StrOut & "Page: " & .Range.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & .Author & vbTab & .Date & vbTab
            End Select
            'Get Revision Type & Scope
            Select Case .Type
              Case wdRevisionDelete
                StrOut = StrOut & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionInsert
                StrOut = StrOut & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedFrom
                StrOut = StrOut & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedTo
                StrOut = StrOut & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionReplace
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionProperty, wdRevisionStyle, wdRevisionParagraphProperty 'Formatting
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case Else
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Other"
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
            End Select
          End With
        ' *****
      Next
    End With
  Next
End With
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
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(StrOut, vbCr))
      xlApp.StatusBar = "Exporting Revision " & i
      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
    .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:L").AutoFit
    For i = 6 To 12
      .Columns(i).ColumnWidth = 80
    Next
    .Rows.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, "¤"), 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 limit processing to just the body of the document, delete:
Code:
  For Each wdRng In .StoryRanges
    With wdRng
and the corresponding:
Code:
    End With
  Next
To extract Word document revisions 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 GetDocumentRevisions()
'Sourced from: https://www.msofficeforums.com/133132-post2.html
'Note: A VBA Reference to Word is required, via Tools|References in the VBE
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|Delete|Insert|From|To|Replace|Format|Other", "|", 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 ExportRevisions(wdApp, CStr(Split(StrFlds, vbCr)(i)))
  Next
Else
  Call ExportRevisions(wdApp, strTpFldr)
End If
wdApp.Quit: Set wdApp = Nothing
If SheetExists("Revisions") = True Then
  Set xlSht = Sheets("Revisions")
Else
  Set xlSht = Sheets.Add
  xlSht.Name = "Revisions"
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:L").AutoFit
  For i = 6 To 12
    .Columns(i).ColumnWidth = 80
  Next
  .Rows.AutoFit
End With
Application.StatusBar = False
MsgBox "Revisions export complete.", vbOKOnly
Application.ScreenUpdating = True
End Sub

Sub ExportRevisions(wdApp As Word.Application, StrFld As String)
Dim strDoc As String, strFls, wdDoc As Word.Document, wdRng As Word.Range, i As Long
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 Each wdRng In .StoryRanges
      With wdRng
        For i = 1 To .Revisions.Count
          If i Mod 100 = 0 Then DoEvents
          'Start a new line
          StrOut = StrOut & vbCr & vbTab & vbTab
          With .Revisions(i)
          'Get Location, Author & .Date
            Select Case wdRng.StoryType
              Case wdEvenPagesFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryFooterStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryFooter" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEvenPagesHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " EvenPagesHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFirstPageHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " FirstPageHeader" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdPrimaryHeaderStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  " PrimaryHeaderStory" & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Endnote: " & .Range.Endnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnotesStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Footnote: " & .Range.Footnotes(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdCommentsStory
                StrOut = StrOut & "Section " & .Range.Sections(1).Index & _
                  "Comment: " & .Range.Comments(1).Index & vbTab & .Author & vbTab & .Date & vbTab
              Case wdEndnoteContinuationNoticeStory, wdEndnoteContinuationSeparatorStory, wdEndnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdFootnoteContinuationNoticeStory, wdFootnoteContinuationSeparatorStory, wdFootnoteSeparatorStory
                StrOut = StrOut & vbTab & .Author & vbTab & .Date & vbTab
              Case wdMainTextStory, wdTextFrameStory
                StrOut = StrOut & "Page: " & .Range.Characters.First.Information(wdActiveEndAdjustedPageNumber) & vbTab & .Author & vbTab & .Date & vbTab
            End Select
            'Get Revision Type & Scope
            Select Case .Type
              Case wdRevisionDelete
                StrOut = StrOut & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionInsert
                StrOut = StrOut & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedFrom
                StrOut = StrOut & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionMovedTo
                StrOut = StrOut & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionReplace
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case wdRevisionProperty, wdRevisionStyle, wdRevisionParagraphProperty 'Formatting
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & TidyText(.Range.Text)
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
              Case Else
                StrOut = StrOut & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Other"
                With .Range
                  If .Information(wdWithInTable) Then StrOut = StrOut & " * in cell " & ColAddr(.Cells(1).ColumnIndex) & .Cells(1).RowIndex & " *"
                End With
            End Select
          End With
        Next
      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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
  #3  
Old 09-13-2018, 05:22 AM
alzasp alzasp is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2016
Novice
Exporting Tracked Changes and Comments to Excel
 
Join Date: Sep 2018
Posts: 2
alzasp is on a distinguished road
Default

When I run the macro I get this error and it highlights the red bold code below. Any thoughts on how the fix this?

"Compile error: "User-defined type not defined"
Code:
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
  #4  
Old 09-13-2018, 02:40 PM
macropod's Avatar
macropod macropod is offline Exporting Tracked Changes and Comments to Excel Windows 7 64bit Exporting Tracked Changes and Comments to Excel Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Did you read the Note one the second line of the code and do as advised?
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
  #5  
Old 11-13-2018, 10:41 AM
earnold517 earnold517 is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2016
Novice
 
Join Date: Nov 2018
Posts: 1
earnold517 is on a distinguished road
Default refine the code and minor issues

Hello, this is a wonderful code. I am new to learning how to do all the VBA tricks and have a few questions.

I also found a code the at extracts the comments as well but the extracting of the paragraph header and title doesn't work. Similar to the first example in this thread.

And one for the changes in the images. I would like to have all these functions in one code.

The goal is I have multiple users contribution to a master document that goes through an update every year and instead of gathering change suggestions comments in excel, then manually making the changes in word, I'd like for the contributors to make the changes, and provide comments directly in word and then i can pull the author, tracked changes, image changes, comments and there specific location out to a tracker. Then with minor manipulation of the tracker i could have it submitted as a formal document of changes to the revision of the document.

Thank you again for any help.
  #6  
Old 11-13-2018, 01:34 PM
macropod's Avatar
macropod macropod is offline Exporting Tracked Changes and Comments to Excel Windows 7 64bit Exporting Tracked Changes and Comments to Excel Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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 View Post
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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
  #7  
Old 12-29-2018, 10:04 PM
macropod's Avatar
macropod macropod is offline Exporting Tracked Changes and Comments to Excel Windows 7 64bit Exporting Tracked Changes and Comments to Excel Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Cross-posted at: Exract Tracked Changes from Word to Excel
For cross-posting etiquette, please read: Excelguru Help Site - A message to forum cross posters
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
  #8  
Old 02-03-2021, 01:08 PM
eokwaro eokwaro is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2016
Novice
 
Join Date: Feb 2021
Location: Nairobi, Kenya
Posts: 3
eokwaro is on a distinguished road
Default Selecting Reference in VBA

How do i select the reference

'Note: A VBA Reference to Excel is required, via Tools|References
  #9  
Old 11-28-2021, 09:41 PM
Guessed's Avatar
Guessed Guessed is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2016
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 3,932
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

The exact library name will vary according the version of Excel you have loaded on your machine. In the VBA editor you need to go to Tools > References and find the library with a name like "Microsoft Excel xx.x Object Library" where xx.x will be a version number.
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
  #10  
Old 01-18-2022, 05:51 AM
zakn zakn is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2021
Novice
 
Join Date: Jan 2022
Posts: 1
zakn is on a distinguished road
Default

The vba in Post #2 from Paul Edstein works like a charm. Need some assistance to modify it to work on all documents in a folder that I can pick and all subfolders.

Thanks for the assistance.
  #11  
Old 03-29-2022, 02:28 PM
Macromate Macromate is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2021
Novice
 
Join Date: Mar 2022
Posts: 3
Macromate is on a distinguished road
Default

Hi Macropod,

If its not too much trouble, could you perhaps guide me on the fastest of way of making the code below work? I'm happy to strip down some functionality (since the area of the code that was showing the compile error allows for custom extracts (vs standard extracts) of comments and track changes. At this point, I'll sacrifice some 'add-on' bells and whistles to just be able to use the code to extract comments/track changes (with the formatting, context etc) to help me with my work.

Looking forward to hearing back from you.

Best,
Macromate

Code:
'============================================================================
'****************************************************************************
'************************  SmartExtract  ********************************
'****************************************************************************
'============================================================================

Sub wrkSmartExtract()
'=================================================================================================
'Extracts Comments and revisions from a source document
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Finds the property containing the name of the source
'Source must be open, the tries to find the page number in the current paragraph
'Then goes to source and then to page
'UPDATED May - Added ability to get extract type
'=================================================================================================
    Dim dSrcDoc As Document
    Dim dExtractDoc As Document
    Dim iCnt As Integer
    Dim rRev As Revision
    Dim cCmt As Comment
    Dim bResetTrackChg As Boolean
 
    Dim iChgArray() As Long 'Col 1=Para Num, Col 2=Type(1=Rev,2=Cmt), 3=Index, 4=Start Pos, 5 = length (highlight)
    Dim iParaNum As Long
    Dim iType As Long
    Dim iIndex As Long
    Dim bMinorRevChg As Boolean
    
    Dim tExtTbl As Table
    Dim iTblRow As Integer
    Dim rTblRow As Row
    Dim bAddTableRow As Boolean
    
    Dim sAuthor As String
    Dim rChgRng As Range
    Dim sChgHdr As String
    Dim sChgText As String
    Dim iChgCnt As Integer
    Dim iMinorRevLen As Integer
    Dim iPageFormatLen As Integer

    Dim sCtxHdr As String
    Dim rCtxRng As Range
    Dim iCtxTblRow As Integer
    Dim sCtxRowCell1Text As String
    Dim bCtxWholePara As Boolean
    
    Dim bExtractComments As Boolean
    Dim bExtractRevisions As Boolean
    Dim bExtractHighlights As Boolean
    Dim sExtractAuthors As String
    Dim iHighlightCnt As Integer
    
    Set dSrcDoc = ActiveDocument
        
    'Added call to get extract type
    Call wrkGetExtractType(sExtractAuthors, bExtractComments, bExtractRevisions, bExtractHighlights, iHighlightCnt)
    If sExtractAuthors = "No Extract" Then Exit Sub
    
    'Here if valid
    Application.ScreenUpdating = False
    bResetTrackChg = False
    
    'Need to set this off so the cut and paste gets carries teh inserts and deletions
    If ActiveDocument.TrackRevisions = True Then
        ActiveDocument.TrackRevisions = False
        bResetTrackChg = True
    End If
    
    If dSrcDoc.Range.Information(wdNumberOfPagesInDocument) >= 100 Then
        iPageFormatLen = 3
    ElseIf dSrcDoc.Range.Information(wdNumberOfPagesInDocument) >= 10 Then
        iPageFormatLen = 2
    Else: iPageFormatLen = 1
    End If
         
    'Load the comments and revisons into the arrary, then sort into order in document
    ReDim iChgArray((dSrcDoc.Comments.Count + dSrcDoc.Revisions.Count + iHighlightCnt), 5)
    Call wrkPrepChgArray(dSrcDoc, sExtractAuthors, bExtractComments, bExtractRevisions, bExtractHighlights, iChgCnt, iChgArray())
    
    'Add New Document and insert the header infromation
    Set dExtractDoc = Documents.Add
    dExtractDoc.PageSetup.Orientation = wdOrientLandscape
    sChgHdr = "Comments extracted from:  " & dSrcDoc.Name & vbCr
    dExtractDoc.Range.Select
    Selection.InsertBefore (sChgHdr)
    Selection.Collapse (wdCollapseEnd)

    'Insert a 5-column table for the comments
    With dExtractDoc
        Set tExtTbl = .Tables.Add _
             (Range:=Selection.Range, numrows:=iChgCnt + 1, NumColumns:=5)
    End With
    'Now prepare the table for the revisions to be added into
    Call wrkSetupTable(tExtTbl)

    'Main routing
    iParaNum = 0
    iTblRow = 0
    iMinorRevLen = 6
    bCtxWholePara = True
    
    For iCnt = 1 To iChgCnt ' for each change
        'get the array values
        StatusBar = "Processing Extract " & iCnt & " of " & iChgCnt
        If iChgArray(iCnt, 1) = 0 Then Exit For 'got to the last row
        iType = iChgArray(iCnt, 2)
        iIndex = iChgArray(iCnt, 3)
        bAddTableRow = True
        sAuthor = ""
        
        If iType = 1 Then Set rRev = dSrcDoc.Revisions(iIndex)
        If iType = 2 Then Set cCmt = dSrcDoc.Comments(iIndex)
        
        'If this is a new paragrah in the sorted array, get the context of the change or comment
        If iParaNum <> iChgArray(iCnt, 1) Then
            iParaNum = iChgArray(iCnt, 1)
            bCtxWholePara = True
            bMinorRevChg = False
            If iType = 1 Then rRev.Range.Select
            If iType = 2 Then cCmt.Scope.Select
            If iType = 3 Then
                dSrcDoc.Range(iChgArray(iCnt, 4), iChgArray(iCnt, 4) + iChgArray(iCnt, 5)).Select
                
            End If
            'Get the contex
            sCtxHdr = "Page " & wrkPadLeftSpaces(Selection.Information(wdActiveEndPageNumber), iPageFormatLen) & ": Line " & wrkPadLeftSpaces(Selection.Information(wdFirstCharacterLineNumber), 2)
            If Selection.Information(wdWithInTable) Then
                iCtxTblRow = Selection.Information(wdStartOfRangeRowNumber)
                 sCtxRowCell1Text = wrkGetCtxRowCell1Text(iCtxTblRow)
                If Len(sCtxRowCell1Text) > 20 Then sCtxRowCell1Text = Left(sCtxRowCell1Text, 20) & "..."
                sCtxHdr = sCtxHdr & "  Table Row: " & sCtxRowCell1Text
                Set rCtxRng = Selection.Cells(1).Range
            Else
                Set rCtxRng = wrkGetParaBasedCtxRng(dSrcDoc, Selection.Range, bCtxWholePara)
            End If
        End If ' New Para
        
        'now process revisions
        Select Case iType
        Case 1 'revision
            With rRev
                sAuthor = .Author
                If Len(.Range.Text) <= iMinorRevLen Then 'is this a minor change?
                    If bMinorRevChg = False Then 'Initial Minor Change
                        bMinorRevChg = True
                        sChgHdr = "Minor Revision:"
                        Call wrkGetMinorChg(dSrcDoc, iChgArray(), iCnt, iChgCnt, iMinorRevLen, sChgText)
                    Else
                        bAddTableRow = False ' second minor change found
                    End If ' first minor change for para
                Else 'Major Change found
                    If .Type = wdRevisionInsert Then
                        sChgHdr = "Inserted:"
                    Else
                        sChgHdr = "Deleted:"
                    End If
                    sChgText = .Range.Text
                End If 'Major Change found
            End With 'rRev
        Case 2  'now process comments
            With cCmt
                sAuthor = .Author
                sChgHdr = "Comment " & .Initial & .Index & ":"
                sChgText = .Range.Text
            End With
        Case 3
            If iCnt > 1 Then
                If iChgArray(iCnt - 1, 4) = iChgArray(iCnt, 4) Then bAddTableRow = False 'Skip Highlight on inserted
            End If ' test if not first row
            sChgHdr = "Highlighted Text:"
            dSrcDoc.Range(iChgArray(iCnt, 4), iChgArray(iCnt, 4) + iChgArray(iCnt, 5)).Select
            sChgText = Selection.Range.Text
            
        End Select
        
        'If a row in the results table is to be added - wont add of not first minor change
        If bAddTableRow Then
            iTblRow = iTblRow + 1
            'Prepare the table entry
            With tExtTbl.Rows(iTblRow + 1)
                .Cells(1).Range.Text = iTblRow
                
                '--- Cell 2 ---
                Call wrkSelectCtxRange(rCtxRng, dSrcDoc, iParaNum)
                .Cells(2).Range.Paste
                If Not bCtxWholePara Then .Cells(2).Range.InsertBefore "     ..."
                .Cells(2).Range.InsertBefore sCtxHdr & vbCr
                'now remove bullets and lists and underline
                If .Cells(2).Range.Paragraphs(1).Range.ListFormat.ListType <> wdListNoNumbering Then _
                        .Cells(2).Range.Paragraphs(1).Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
                If .Cells(2).Range.Paragraphs(1).Range.HighlightColorIndex <> wdNoHighlight Then _
                        .Cells(2).Range.Paragraphs(1).Range.HighlightColorIndex = wdNoHighlight
                
                .Cells(2).Range.Paragraphs(1).Range.Font.Underline = wdUnderlineSingle
                '--- Cell 3 ---
                .Cells(3).Range.Text = sChgHdr & vbCr & sChgText
                .Cells(3).Range.Paragraphs(1).Range.Font.Underline = wdUnderlineSingle
                '--- Cell 4 ---
                .Cells(4).Range.Text = sAuthor
             End With
        End If 'adding table Row
    Next iCnt
    
    dSrcDoc.Activate
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.View.ShowRevisionsAndComments = True
    
    If bResetTrackChg Then ActiveDocument.TrackRevisions = True
    dExtractDoc.Activate
        
    iCnt = 0 'Remove blank rows in the talble
    Do While tExtTbl.Rows.Last.Cells(1).Range.Characters.Count <= 1
        'until first non null row found
        tExtTbl.Rows.Last.Delete
        iCnt = iCnt + 1
        StatusBar = "Blank Table Row" & iCnt
    Loop
        
    'Remove source formatting in context col
    StatusBar = "Formatting Extract"
    tExtTbl.Columns(1).Select
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    tExtTbl.Columns(2).Select
    With Selection
        .ParagraphFormat.Alignment = wdAlignParagraphLeft
        .Font.Size = 9
        .Font.Bold = False
        .ParagraphFormat.SpaceBefore = 0
        .ParagraphFormat.SpaceBefore = 0
    End With
    tExtTbl.Rows(1).Range.Font.Bold = True
    
    'Mark scope of comments and then delete them
    For Each cCmt In dExtractDoc.Comments
        cCmt.Scope.HighlightColorIndex = wdGray25
    Next cCmt
    Do While dExtractDoc.Comments.Count >= 1
        dExtractDoc.Comments(1).Delete
    Loop
    Call wrkAcceptAllFormatChanges("No Prompt")
    
    'Done
    Application.ScreenUpdating = True
    dExtractDoc.CustomDocumentProperties.Add Name:="dpSmartExtractSource", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=dSrcDoc.Name
    Selection.HomeKey Unit:=wdStory

    MsgBox tExtTbl.Rows.Count - 1 & " entries written", , "SmartExtract"

End Sub
Function wrkPadLeftSpaces(vSource As Variant, iPadLength As Integer) As String
    wrkPadLeftSpaces = Right((Space(iPadLength) & vSource), iPadLength)
End Function
Function wrkGetCtxRowCell1Text(iCtxTblRow As Integer) As String
    'Separate routine so that if there are merged cells in the table, no error is generated
    wrkGetCtxRowCell1Text = iCtxTblRow
    On Error Resume Next
    wrkGetCtxRowCell1Text = wrkGetCellText(Selection.Tables(1).Rows(iCtxTblRow).Cells(1).Range)
End Function
Function wrkGetParaBasedCtxRng(dSrcDoc As Document, rChgRng, bCtxWholePara As Boolean) As Range
'=================================================================================================
'Ensures that there is at least 150 characters of context
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Keeps adding paragraphs to the context until there are at least 150 characters in the context
' Assumes not in a table
'=================================================================================================
    Dim iStartPara As Long
    Dim iEndPara As Long
    Dim iChgStart As Long
    Dim iStartCtx As Long
    Dim iMinCtx As Long
    Dim iMaxCtx As Long
    Dim iReposCtx As Long
    
    
    iMinCtx = 30 ' min words in context
    iMaxCtx = 80 ' max words
    
    'set the start point for the change
    iChgStart = ActiveDocument.Range(0, rChgRng.Start).Words.Count
    
    'now get the paragraph range that the change occurs in
    Set wrkGetParaBasedCtxRng = rChgRng
    wrkGetParaBasedCtxRng.Select
    iStartPara = wrkGetParaNumSelection
    iEndPara = wrkGetParaNumSelection("End")
    
    'Now select the paragraph range
    wrkGetParaBasedCtxRng.SetRange Start:=dSrcDoc.Paragraphs(iStartPara).Range.Start, End:=dSrcDoc.Paragraphs(iEndPara).Range.End
    iStartCtx = ActiveDocument.Range(0, wrkGetParaBasedCtxRng.Start).Words.Count
    
    'now loop adding paragraphs
    Do While iStartPara > 1 And (iChgStart - iStartCtx) < iMinCtx
       If dSrcDoc.Paragraphs(iStartPara - 1).Range.Information(wdWithInTable) Then Exit Do
       iStartPara = iStartPara - 1
       wrkGetParaBasedCtxRng.SetRange Start:=dSrcDoc.Paragraphs(iStartPara).Range.Start, End:=wrkGetParaBasedCtxRng.End
       iStartCtx = ActiveDocument.Range(0, wrkGetParaBasedCtxRng.Start).Words.Count
    Loop
    If (iChgStart - iStartCtx) > iMaxCtx Then
        iReposCtx = (iChgStart - iMaxCtx) - iStartCtx
        wrkGetParaBasedCtxRng.MoveStart Unit:=wdWord, Count:=iReposCtx
         bCtxWholePara = False
    End If
End Function

Private Sub wrkGetMinorChg(dSrcDoc As Document, iChgArray() As Long, iCnt As Integer, iChgCnt As Integer, _
                            iMinorRevLen As Integer, sChgText As String)
'=================================================================================================
'Reads all changes for the same para and builds a string of minor changes
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'=================================================================================================
    Dim iNext As Long
    Dim iCurPara As Long
    Dim rChgRng As Range
       
    'First minor change
    iNext = iCnt
    iCurPara = iChgArray(iNext, 1)
    sChgText = dSrcDoc.Revisions(iChgArray(iNext, 3)).Range.Text
    
    iNext = iNext + 1
    Do
        If iNext > iChgCnt Then Exit Do ' - exits to handle last change
        If iChgArray(iNext, 1) <> iCurPara Then Exit Do 'next parra found - exits to handle last para in doc
        If iChgArray(iNext, 5) <= iMinorRevLen And iChgArray(iNext, 2) = 1 Then 'minor revision
            sChgText = sChgText & vbCr & dSrcDoc.Revisions(iChgArray(iNext, 3)).Range.Text
        End If
        iNext = iNext + 1
    Loop

End Sub

Private Sub wrkSelectCtxRange(rCtx As Range, dDoc As Document, iPara As Long)
'=================================================================================================
'Gets the range of the context
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Has complex logic to handle changes arising from whole table row deleted
'=================================================================================================
    On Error GoTo CopyError
    rCtx.Copy
    Exit Sub ' simple copy worked fine - main flow
    'If the Ctx range cannot be copied - Cused by:1-whole table row deleted
CopyError:
    iPara = iPara - 1 ' error found - get the prev para
    Resume TryPrevPara
TryPrevPara:
    On Error GoTo CopyError
    dDoc.Paragraphs(iPara).Range.Copy
End Sub
Private Sub wrkSetupTable(tTable As Table)
'=================================================================================================
'Sets up the table where the extracts are loaded
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'=================================================================================================
    With tTable
        If .Style <> "Table Grid" Then
            .Style = "Table Grid"
        End If
        .Rows.AllowBreakAcrossPages = False
        .Range.Style = wdStyleNormal
        .Range.Font.Size = 9
        .AllowAutoFit = False
        .PreferredWidthType = wdPreferredWidthPercent
        .PreferredWidth = 100
        .Columns.PreferredWidthType = wdPreferredWidthPercent
        .Columns(1).PreferredWidth = 5
        .Columns(2).PreferredWidth = 40
        .Columns(3).PreferredWidth = 30
        .Columns(4).PreferredWidth = 10
        .Columns(5).PreferredWidth = 15
        .Rows(1).HeadingFormat = True
        If .Rows(1).Shading.BackgroundPatternColor = wdColorAutomatic Then
             .Rows(1).Shading.BackgroundPatternColor = wdColorGray10
        End If
    End With

    'Insert table headings
    With tTable.Rows(1)
        .Range.Font.Bold = True
        .Cells(1).Range.Text = "Item"
        .Cells(2).Range.Text = "Context"
        .Cells(3).Range.Text = "Comment or Revision"
        .Cells(4).Range.Text = "Author"
        .Cells(5).Range.Text = "Action"
   End With
End Sub
Private Sub wrkPrepChgArray(dDoc As Document, sExtractAuthors As String, bExtractComments As Boolean, _
                          bExtractRevisions As Boolean, bExtractHighlights As Boolean, iChgCnt As Integer, iChgArray() As Long)
'=================================================================================================
'Loads an arrary of changes - revisions, then comments, then sorts them into order in document
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Skips all revisions except insertions and deletions
'Skips Table of contents changes
'UPDATED May 15 - to include flags for each type of extract
'=================================================================================================
    Dim rRev As Revision
    Dim cCmt As Comment
    Dim iParaNum As Long
    Dim bIncludeItem As Boolean
    Dim iCharNum As Long
    Dim sChgText As String
    Dim iPrevHighlightChar As Long
    Dim rHighlightRng As Range
    Dim iHighlightPrevStart As Long
       
    'Found instances of deleted revisions not seen in the UI haning around in the document - skip them
    On Error GoTo SkipDeletedRevisions
    iChgCnt = 0
    If bExtractRevisions Then
        For Each rRev In dDoc.Revisions
            With rRev
                bIncludeItem = False
                'Only include insertions and deletions
                If .Type = wdRevisionInsert Or .Type = wdRevisionDelete Then bIncludeItem = True
                'Exclude Author if not wanted
                If bIncludeItem Then
                    If sExtractAuthors <> "ALL" Then
                        If InStr(sExtractAuthors, .Author) = 0 Then bIncludeItem = False
                    End If
                End If
                
                'Skip contents changes
                If bIncludeItem Then 'First para may not be TOC in some scenarios
                    If InStr(.Range.Paragraphs(1).Style, "TOC") > 0 Then bIncludeItem = False
                End If
                If bIncludeItem And .Range.Paragraphs.Count >= 2 Then 'First para may not be TOC in some scenarios
                    If InStr(.Range.Paragraphs(2).Style, "TOC") > 0 Then bIncludeItem = False
                End If
                
                If bIncludeItem Then
                    iChgCnt = iChgCnt + 1
                    StatusBar = "Preparing Revsions. Item " & iChgCnt
    
                    .Range.Select
                    iParaNum = wrkGetParaNumSelection
                    iCharNum = Selection.Start
                    iChgArray(iChgCnt, 1) = iParaNum
                    iChgArray(iChgCnt, 2) = 1
                    iChgArray(iChgCnt, 3) = .Index
                    iChgArray(iChgCnt, 4) = iCharNum
                    iChgArray(iChgCnt, 5) = Len(.Range.Text)
                End If
            End With
        Next rRev
    End If
SkipDeletedRevisions:
    
    If bExtractComments Then
        For Each cCmt In dDoc.Comments
            With cCmt
                bIncludeItem = True
                If sExtractAuthors <> "ALL" Then
                    If InStr(sExtractAuthors, .Author) = 0 Then
                        bIncludeItem = False
                    End If
                End If
                If bIncludeItem Then
                    iChgCnt = iChgCnt + 1
                    StatusBar = "Preparing Comments, Item " & iChgCnt
                    .Scope.Select
                    iParaNum = wrkGetParaNumSelection
                    iCharNum = Selection.Start
                    iChgArray(iChgCnt, 1) = iParaNum
                    iChgArray(iChgCnt, 2) = 2
                    iChgArray(iChgCnt, 3) = .Index
                    iChgArray(iChgCnt, 4) = iCharNum
                End If
            End With
        Next cCmt
    End If
   
    If bExtractHighlights Then
        Set rHighlightRng = dDoc.Range
        rHighlightRng.Find.Highlight = True
        rHighlightRng.Find.Forward = True
        
        Do While rHighlightRng.Find.Execute
            If rHighlightRng.Start = iHighlightPrevStart Then Exit Do
            iHighlightPrevStart = rHighlightRng.Start
            rHighlightRng.Select
           
            iChgCnt = iChgCnt + 1
            StatusBar = "Preparing Highlights, Item " & iChgCnt
            iCharNum = Selection.Start
            iParaNum = wrkGetParaNumSelection
            iChgArray(iChgCnt, 1) = iParaNum
            iChgArray(iChgCnt, 2) = 3
            iChgArray(iChgCnt, 3) = 0
            iChgArray(iChgCnt, 4) = iCharNum
            iChgArray(iChgCnt, 5) = Len(Selection.Range.Text)
        Loop

    End If 'Extract Highlights
    
    iChgArray = wrkBubbleSort(iChgArray, 4, "Ascending", iChgCnt)
End Sub

Sub wrkGetExtractType(sExtractAuthors As String, bExtractComments As Boolean, _
                                            bExtractRevisions As Boolean, bExtractHighlights As Boolean, iHighlightCnt As Integer)
'=================================================================================================
'Determines what type of extract is needed - standard or custom
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Sets a boolen for each type (cmt, rev, highlight) and a list of authors to extect (or All)
'Skips Table of contents changes
'=================================================================================================
    Dim rHighlightRng As Range
    Dim iHighlightPrevStart As Long
    Dim sInputVal As String
    Dim rRev As Revision
    Dim cCmt As Comment
    Dim iCnt As Integer
    Dim sRevAuthors(15) As String  'First 14 authors from 1-15
    Dim iRevCount(15, 2) As Integer '1=Comment Counts, 2= Revison Counts per author
    Dim i As Integer
    Dim iAuthorIndex As Integer 'current author
    Dim iAuthorMaxIndex As Integer ' Number of authors in doc
    Dim sAuthors As String 'String containing the names of the authors to extract
    Dim sAuthorIndex As String 'String showing the authors and comment and revision counts for each
    
    'Application.Sc5reenUpdating = False

    StatusBar = "Preparing revision statistcs"
    
    
    'First count the highlighed sections
    Set rHighlightRng = ActiveDocument.Range
    rHighlightRng.Find.Highlight = True
    rHighlightRng.Find.Forward = True
   
   
    Do While rHighlightRng.Find.Execute
        If rHighlightRng.Start = iHighlightPrevStart Then Exit Do
        iHighlightPrevStart = rHighlightRng.Start
        iHighlightCnt = iHighlightCnt + 1
        iHighlightPrevStart = rHighlightRng.Start
    Loop
    If iHighlightCnt > 0 Then
        bExtractHighlights = True
    Else
        bExtractHighlights = False
    End If
    'Assume otyher types are extected
    bExtractComments = True
    bExtractRevisions = True
    'bExtractHighlights = False
    sExtractAuthors = "ALL"
    
    sInputVal = wrkGetInput("The document contains:" & vbNewLine & vbNewLine & _
                            "     Comments: " & ActiveDocument.Comments.Count & vbNewLine & _
                            "     Revisions   : " & ActiveDocument.Revisions.Count & vbNewLine & _
                            "     Highlights : " & iHighlightCnt & vbNewLine & vbNewLine & _
                            "Perform Standard (full extract) or Custom extract? S/C", "SmartExtract", "S", "S|C", True)
    If sInputVal = "" Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    'Exit if Standard extract - the attribures are
    If sInputVal = "S" Then Exit Sub
    
    'here if custom extract
    iAuthorMaxIndex = 0
    iCnt = 0
    'Now count the  comments by author
    For Each cCmt In ActiveDocument.Comments
        With cCmt
            iCnt = iCnt + 1
            StatusBar = "Checking Comments. Item " & iCnt
            
            iAuthorIndex = 0
            For i = 1 To UBound(sRevAuthors)
                If sRevAuthors(i) = "" Then Exit For
                If sRevAuthors(i) = .Author Then
                    iAuthorIndex = i
                    Exit For
                End If
            Next i
            If iAuthorIndex = 0 And iAuthorMaxIndex < UBound(sRevAuthors) Then
                iAuthorMaxIndex = iAuthorMaxIndex + 1
                iAuthorIndex = iAuthorMaxIndex
                sRevAuthors(iAuthorIndex) = .Author
            End If
            If iAuthorIndex > 0 Then iRevCount(iAuthorIndex, 1) = iRevCount(iAuthorIndex, 1) + 1
        End With
    Next cCmt
    'Now count the revisions
    ' in some large documents  there may be deleted revisions - unclear why these are there - not seen in the UI
    On Error GoTo SkipDeletedRevisions
    iCnt = 0
    For Each rRev In ActiveDocument.Revisions
        With rRev
            'Only include insertions and deletions
            If .Type = wdRevisionInsert Or .Type = wdRevisionDelete Then
                iCnt = iCnt + 1
                StatusBar = "Checking Revsions. Item " & iCnt
                
                iAuthorIndex = 0
                For i = 1 To UBound(sRevAuthors)
                    If sRevAuthors(i) = "" Then Exit For
                    If sRevAuthors(i) = .Author Then
                        iAuthorIndex = i
                        Exit For
                    End If
                Next i
                If iAuthorIndex = 0 And iAuthorMaxIndex < UBound(sRevAuthors) Then
                    iAuthorMaxIndex = iAuthorMaxIndex + 1
                    iAuthorIndex = iAuthorMaxIndex
                    sRevAuthors(iAuthorIndex) = .Author
                End If
                If iAuthorIndex > 0 Then iRevCount(iAuthorIndex, 2) = iRevCount(iAuthorIndex, 2) + 1
              End If
        End With
    Next rRev
SkipDeletedRevisions:

    'Now build a string to show what authors are in the document
    sAuthors = ""
    For i = 1 To iAuthorMaxIndex
        If i > 1 Then sAuthors = sAuthors & vbNewLine
         sAuthors = sAuthors & " " & i & " " & sRevAuthors(i) & " - Cmts: " & iRevCount(i, 1) & " Revs: " & iRevCount(i, 2)
    Next i
    sExtractAuthors = ""
    sInputVal = wrkGetInput("The following authors are have made revisions: " & vbNewLine & vbNewLine & _
                                sAuthors & vbNewLine & vbNewLine & _
                            "Enter the number of each to extract separated by commas. Leave blank for all.", "SmartExtract", "", "", True)
    
    If sInputVal = "" Then
        sExtractAuthors = "ALL"
    Else
        sInputVal = "," & sInputVal & ","
        sExtractAuthors = "|"
        'Now get the names of the authors whose numbers had been entered
        For i = 1 To iAuthorMaxIndex
            sAuthorIndex = "," & i & ","
            If InStr(sInputVal, sAuthorIndex) > 0 Then
                sExtractAuthors = sExtractAuthors & sRevAuthors(i) & "|"
            End If
        Next i
    End If
    
    'Check if comments are extracted - decided to always ask for these even if there are none
    sInputVal = wrkGetInput("Extract Comments? Y/N", "SmartExtract", "Y", "Y|N", True)
    If sInputVal = "" Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    If sInputVal = "N" Then bExtractComments = False
    
    sInputVal = wrkGetInput("Extract Revisions? Y/N", "SmartExtract", "Y", "Y|N", True)
    If sInputVal = "" Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    If sInputVal = "N" Then bExtractRevisions = False
    
    'Only offer Highlight counts if there are any
    If bExtractHighlights Then
        sInputVal = wrkGetInput("Extract highlighted sections? Y/N", "SmartExtract", "Y", "Y|N", True)
        If sInputVal = "" Then
            sExtractAuthors = "No Extract"
            Exit Sub
        End If
        If sInputVal = "N" Then bExtractHighlights = False
    End If
    
    If Not bExtractComments And Not bExtractRevisions And Not bExtractHighlights Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    
    Application.ScreenUpdating = True
    
End Sub
    
Function wrkBubbleSort(InputArray As Variant, Optional SortColumn As Integer = 1, _
                          Optional SortOrder As String = "Ascending", _
                          Optional intMaxRows As Integer = 0) As Variant
'=============================================================================================
' Sort a 2-Dimension Array (Credit: Rajan Verma + DocumentProductivity)
' Parameter Info
' InputArray  : Array you want to Sort
' SortColumn  : on Which column you want to sort
' SortOrder   : xlAscending , xlDescending
' intMaxRows  : if >0 will sort only rows 1-MaxRow.  Leaves null rows untouched
'=============================================================================================
    Dim intFirst As Integer
    Dim intLast  As Integer
    Dim intFirstCol As Integer
    Dim intLastCol  As Integer
    Dim sngTemp     As Single
    Dim lngLoop1    As Integer
    Dim i           As Integer
    Dim j           As Integer
    Dim blnFlag     As Boolean
    Dim blnSort     As Boolean
    
    If Not IsArray(InputArray) Then
        blnFlag = True
        GoTo ExitEarly:
    End If
    
    intFirst = LBound(InputArray, 1)
    If intMaxRows > 0 Then
        intLast = intMaxRows
    Else
        intLast = UBound(InputArray, 1)
    End If
    intFirstCol = LBound(InputArray, 2)
    intLastCol = UBound(InputArray, 2)
    StatusBar = "Sorting..."
    For i = intFirst To intLast - 1

        For lngLoop1 = i + 1 To intLast
            If SortOrder = "Ascending" Then
                If InputArray(i, SortColumn) > InputArray(lngLoop1, SortColumn) Then blnSort = True
            Else
                If InputArray(i, SortColumn) < InputArray(lngLoop1, SortColumn) Then blnSort = True
            End If
                If blnSort Then
                    For j = intFirstCol To intLastCol
                        sngTemp = InputArray(lngLoop1, j)
                        InputArray(lngLoop1, j) = InputArray(i, j)
                        InputArray(i, j) = sngTemp
                    Next j
                End If
            blnSort = False
        Next lngLoop1
    Next i
    wrkBubbleSort = InputArray
ExitEarly:
    If blnFlag Then wrkBubbleSort = Null
End Function

'=================================================================================================
'========= Small routines =========================================================================
'=================================================================================================

Sub wrkAcceptAllFormatChanges(sPrompt As String)
'=================================================================================================
'Accepts all format changes in a document
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Used a standalone routine and also as part of SmartExtract to clean up the extracted text
'================================================================================================
    Dim rRev As Revision
    Dim iCnt As Long
    Dim sInputVal As String
    Dim iRevCnt As Integer
    Dim iRev As Integer
    Dim bAcceptRev As Boolean

    
    If sPrompt = "Prompt" Then
        If ActiveDocument.Revisions.Count = 0 Then
            MsgBox "There are no changes in this document to accept"
            Exit Sub
        Else
            sInputVal = wrkGetInput("Do You want to Accept all Formatting Changes? Y/N", _
                                    "Accept Formatting Changes", "Y", "Y|N", True)
            If sInputVal <> "Y" Then
                Exit Sub
            End If
        End If
    End If ' Propmt
    'here if valid
    'Need to skip deleted revisions that hang around in some large documents
On Error GoTo SkipDeletedRevisions
    iRevCnt = ActiveDocument.Revisions.Count
    For Each rRev In ActiveDocument.Revisions
        iRev = iRev + 1
        StatusBar = "Checking revision " & iRev & " of " & iRevCnt
        bAcceptRev = False
        With rRev
            If Not bAcceptRev And .Range.Paragraphs.Count >= 2 Then ' First parara
                If InStr(.Range.Paragraphs(2).Style, "TOC") > 0 Then bAcceptRev = True
            End If
            If Not bAcceptRev And (.Type = wdRevisionProperty Or _
                                    .Type = wdRevisionTableProperty Or _
                                    .Type = wdRevisionParagraphProperty) Then bAcceptRev = True
            If bAcceptRev Then
                rRev.Accept
                iCnt = iCnt + 1
            End If
        End With
    Next rRev
SkipDeletedRevisions:
     If sPrompt = "Prompt" Then MsgBox iCnt & " Formatting changes were accepted"
 End Sub

'============================================================================
'****************************************************************************
'************************  Smart Bookmark  ********************************
'****************************************************************************
'============================================================================
Sub dpSmartBookmark()
'=================================================================================================
'First use drops a bookmark, second use returns to the initial bookmark
'Release 13 Apr 2016 Martin Coomber documentproductivity.blogspot.co.nz
'If the intitial bookmark isnt returned to after 5 mins, a new return location will be started
'If double pressed, got to top of doc
'Goes to the SmartExtract source location if used in a smart extract cell
'assgined to Ctl+`
'=================================================================================================
    Dim nTimerDiff As Single
        
    'First check if the Goto call is inside a smartextract document. If so, goto the page
    If wrkDocPropExists("dpSmartExtractSource") Then 'Current document was created by SmartExtract,
        'Go to correct page in the source document
        Call wrkGotoSmartExtract
        Exit Sub
    End If
    
    nTimerDiff = Timer - glbSmtBmkLast
    
    If ActiveDocument.Bookmarks.Exists("dpTempGoto") = True Then
        If nTimerDiff > 900 Then 'After 5 mins begin a return location
            ActiveDocument.Bookmarks("dpTempGoto").Delete
            ActiveDocument.Bookmarks.Add Name:="dpTempGoto", Range:=Selection.Range
            StatusBar = "Bookmark Dropped"
            glbSmtBmkLast = Timer
        ElseIf nTimerDiff > 1 Then 'single press with existing bookmark means return
            Selection.GoTo what:=wdGoToBookmark, Name:="dpTempGoto"
            ActiveDocument.Bookmarks("dpTempGoto").Delete
            StatusBar = "Returned to Bookmark"
        Else 'Double press
            ActiveDocument.Bookmarks("dpTempGoto").Delete
            ' Got to TOC or top of document
            If ActiveDocument.TablesOfContents.Count >= 1 Then
                Selection.HomeKey Unit:=wdStory
                Selection.GoTo what:=wdGoToField, Which:=wdGoToNext, Count:=1, Name:="TOC"
                StatusBar = "Moved to Table of Contents"
            Else
                Selection.HomeKey Unit:=wdStory
                StatusBar = "Moved to Beginning"
            End If
        End If
    Else
        ActiveDocument.Bookmarks.Add Name:="dpTempGoto", Range:=Selection.Range
        StatusBar = "Bookmark Dropped"
        glbSmtBmkLast = Timer
    End If

End Sub
Private Sub wrkGotoSmartExtract()
'=================================================================================================
'Goes to the correct page in the source document for SmartExtract
'Release 13 Apr 2016 Martin Coomber documentproductivity.blogspot.co.nz
'Finds the property containing the name of the source
'Source must be open, the tries to find the page number in the current paragraph
'Then goes to source and then to page
'=================================================================================================
    Dim sSrcName As String
    Dim sHeaderText As String
    Dim bDocumentFound As Boolean
    Dim dDoc As Document
    Dim sPageNum As String
    
    sHeaderText = "Comments extracted from:  "
    bDocumentFound = False
    
    'The name of the soruce document is stored in this propert
    If wrkDocPropExists("dpSmartExtractSource") Then
        'get the page number
        If Left(Selection.Range.Paragraphs(1).Range.Text, 5) = "Page " And _
            InStr(Selection.Range.Paragraphs(1).Range.Text, ":") Then
            sPageNum = Mid(Selection.Range.Paragraphs(1).Range.Text, 6, InStr(Selection.Range.Paragraphs(1).Range.Text, ":") - 6)
        End If
        
        'Now check that the document is open
        sSrcName = ActiveDocument.CustomDocumentProperties("dpSmartExtractSource").Value
        For Each dDoc In Documents
            If dDoc.Name = sSrcName Then
                bDocumentFound = True
                Exit For
            End If
        Next dDoc
    End If
    
    'if document is found then go to the relevant page, if not error.
    If bDocumentFound Then
        dDoc.Activate
        If Val(sPageNum) > 0 Then Selection.GoTo what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Val(sPageNum)
    Else
        MsgBox "The following SmartExtact source is not open." & vbCr & sSrcName, , "SmartExtract"
    End If
End Sub
  #12  
Old 03-29-2022, 03:25 PM
macropod's Avatar
macropod macropod is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Macromate: Did you try the code from posts #2 & #6?

zakn: Posts #2 & #6 include versions of the code to process multiple documents in a folder and, optionally, its sub-folders.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
  #13  
Old 03-29-2022, 04:32 PM
Macromate Macromate is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2021
Novice
 
Join Date: Mar 2022
Posts: 3
Macromate is on a distinguished road
Default

I did try to run the code in post #2, although I was encountering a compile error (user-defined type not defined).

I've attached the table format (which shows how the data is extracted and presented in the table. Could this table perhaps be made in shorter, more efficient code?
Attached Files
File Type: docx Comments and Revisions - Table.docx (75.1 KB, 18 views)
  #14  
Old 03-29-2022, 11:28 PM
macropod's Avatar
macropod macropod is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2016
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Quote:
Originally Posted by Macromate View Post
I did try to run the code in post #2, although I was encountering a compile error (user-defined type not defined).
Doubtless that's the issue discussed in posts #3 & #4. See also posts #8 & #9.
Quote:
Originally Posted by Macromate View Post
I've attached the table format (which shows how the data is extracted and presented in the table. Could this table perhaps be made in shorter, more efficient code?
Something like that is quite achievable. Try the code from post #2, though, as it already gives a lot more information about tracked changes, as does the macro for comments in post #6.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
  #15  
Old 06-14-2022, 02:13 AM
husk husk is offline Exporting Tracked Changes and Comments to Excel Windows 10 Exporting Tracked Changes and Comments to Excel Office 2021
Novice
 
Join Date: Jun 2022
Posts: 1
husk is on a distinguished road
Default

Works great. Thank You!
Closed Thread

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Convert specific author's name in comments and tracked changes to another name rmk911 Word VBA 2 12-09-2021 09:14 PM
Tracked changes and comments disappeared with All Markup selected sleake Word 4 06-18-2018 05:12 AM
Exporting Tracked Changes and Comments to Excel Word for Mac 2011 - Lost all tracked changes and all comments Clint57 Word 1 08-24-2017 06:56 PM
Merging certain Tracked Changes and Comments The_Chefkoch Word 0 02-01-2017 07:22 AM
Exporting Tracked Changes and Comments to Excel Restrict editing: allowing forms, tracked changes AND comments andylaw31 Word 1 08-14-2015 03:13 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 07:26 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft