#1
|
|||
|
|||
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
|
||||
|
||||
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 Code:
For Each wdRng In .StoryRanges With wdRng Code:
End With Next 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
|
|||
|
|||
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
|
||||
|
||||
Did you read the Note one the second line of the code and do as advised?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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
|
||||
|
||||
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:
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 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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
||||
|
||||
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
|
|||
|
|||
Selecting Reference in VBA
How do i select the reference
'Note: A VBA Reference to Excel is required, via Tools|References |
#9
|
||||
|
||||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
||||
|
||||
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
|
|||
|
|||
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? |
#14
|
||||
|
||||
Quote:
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
|
|||
|
|||
Works great. Thank You!
|
|
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 |
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 |
Restrict editing: allowing forms, tracked changes AND comments | andylaw31 | Word | 1 | 08-14-2015 03:13 PM |