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:
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]
|