#1
|
|||
|
|||
Batch compare word documents with a summary report
I am wanting to write a VBA script that compares a set of documents in one folder with a set of documents in a second folder (they have the same names, generated at different times). The tracked changes comparison is then saved to a third folder. My intention is then to loop through these tracked changes documents and create a summary report that has two tables: 1) Table that specifies the name of the file and whether there were changes or not. 2) Detailed table that specified revisions.
I have the first part of the VBA working, which loops through all the files and successfully saves the tracked changes version. I have no idea where to even begin with getting the second part (the summary report) up and working. Code:
Sub Compare() Dim wd As Word.Application Dim odoc As Word.Document Dim rdoc As Word.Document Dim strOPath As String Dim strRPath As String Dim strCPath As String Dim strORTFfile As String Dim ofiles() As String Dim i As Integer Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .title = "Select the folder that contains the original files." If .Show = -1 Then strOPath = .SelectedItems(1) & Application.PathSeparator Else MsgBox "You did not select a folder." Exit Sub End If End With With fd .title = "Select the folder that contains the revised files." If .Show = -1 Then strRPath = .SelectedItems(1) & Application.PathSeparator Else MsgBox "You did not select a folder." Exit Sub End If End With With fd .title = "Select the folder where the comparison files will be saved." If .Show = -1 Then strCPath = .SelectedItems(1) & Application.PathSeparator Else MsgBox "You did not select a folder." Exit Sub End If End With Set wd = GetObject(, "Word.Application") If wd Is Nothing Then Set wd = CreateObject("Word.Application") End If ReDim Preserve ofiles(0) strORTFfile = Dir(strOPath & "\" & ("*.rtf"), vbNormal) Do While strORTFfile <> Empty ReDim Preserve ofiles(UBound(ofiles) + 1) ofiles(UBound(ofiles)) = strORTFfile strORTFfile = Dir Loop For i = 1 To UBound(ofiles) If Dir(strRPath & "\" & ofiles(i)) <> Empty Then Set odoc = wd.Documents.Open(strOPath & "\" & ofiles(i)) Set rdoc = wd.Documents.Open(strRPath & "\" & ofiles(i)) Set ndoc = Application.CompareDocuments(OriginalDocument:=odoc, _ RevisedDocument:=rdoc, _ Destination:=wdCompareDestinationNew, _ Granularity:=wdGranularityWordLevel, _ CompareFormatting:=True, _ CompareCaseChanges:=True, _ CompareWhitespace:=True, _ CompareTables:=True, _ CompareHeaders:=True, _ CompareFootnotes:=False, _ CompareTextboxes:=True, _ CompareFields:=True, _ CompareComments:=True, _ CompareMoves:=True, _ RevisedAuthor:="USERNAME", _ IgnoreAllComparisonWarnings:=False) ActiveWindow.ShowSourceDocuments = wdShowSourceDocumentsNone ActiveWindow.Visible = False ofiles(i) = Replace(ofiles(i), Chr(13), "") ndoc.SaveAs2 FileName:=strCPath & "\" & ofiles(i), _ FileFormat:=wdFormatRTF, LockComments:=False, _ Password:="", AddToRecentFiles:=True, WritePassword:="", _ ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False, CompatibilityMode:=0 odoc.Close SaveChanges = False rdoc.Close SaveChanges = False ndoc.Close SaveChanges = False End If Next End Sub |
#2
|
||||
|
||||
I've done such a macro to gather metrics and detail the comments. I'm not convinced that detailing all the revisions is actually useful since the context of additions and deletions is important and there isn't much value in seeing just the deletion/addition in a sterile environment.
Since the macro I have is quite involved and proprietary, I'm not going to share all its workings in one go but can help guide you through the development of your macro and help you with any sticking points. Let's start with the basic idea of: 1. In an empty Word doc (aDoc), add a table (aTbl) to collect the statistics of each document examined. Add columns for filename, # comments, # revisions, etc 2. Start looping through a folder of documents. Open each doc and: a. add a row to aTbl and report the current doc's basic info b. While the current doc is open, at the end of aDoc insert the doc name and apply Heading style to it. Then if the revision count > 0 add a table below the heading to collect the revision info. Here is step 1 along with most of the variables you will need for later steps. Code:
Dim objFSO As Object, objFolder As Object, objFile As Object Dim i As Integer, sPath As String, aPict As InlineShape, dblRatio As Double Dim aRng As Range, aRngHead As Range, aRngScope As Range, sFile As String Dim aShp As Shape, aDoc As Document, aDocSrc As Document, sVal As String Dim aTbl As Table, aTblComm As Table, aRow As Row, aComment As Comment Dim aFld As Field, sClass As String Set aDoc = ActiveDocument 'Setup Log Table Set aTbl = aDoc.Tables.Add(aDoc.Range, 1, 4) With aTbl .Cell(1, 1).Range.Text = "Filename" .Cell(1, 2).Range.Text = "Comments" .Cell(1, 3).Range.Text = "Tracked Revs" .Cell(1, 4).Range.Text = "Other" .PreferredWidthType = wdPreferredWidthPercent .PreferredWidth = 100 .Columns.PreferredWidthType = wdPreferredWidthPercent .Columns.PreferredWidth = 10 .Columns(1).PreferredWidth = 70 '100 - (.Columns.Count - 1) * 10 End With
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
Great news - I have been able to create what I need. The logic of stepping through the process is what I was missing, and the code I ended up using is a bit different to the snippet you provided.
Thankfully my situation is quite specific and narrow in that all the documents I am comparing are tables and text only, no figures. As correctly pointed out, I immediately saw the issue with my original approach if I was going to capture all the specific revisions, so instead I created a summary report which will state whether there were updates or not, and then the number of revisions. Code:
Sub TCwithSummReport() Dim wd As Word.Application Dim oDoc As Word.Document Dim rdoc As Word.Document Dim oTCDoc As Document Dim oNewDoc As Document Dim oTable As Table Dim oRow As Row Dim oCol As Column Dim oRange As Range Dim oRevision As Revision Dim strText As String Dim n As Long Dim j As Long Dim Title As String Dim strOPath As String Dim strRPath As String Dim strCPath As String Dim strORTFfile As String Dim ofiles() As String Dim i As Integer ' User identification of folders containing original and revised versions, as well as the folder where the tracked changes comparison are to be saved Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .Title = "Select the folder that contains the original files." If .Show = -1 Then strOPath = .SelectedItems(1) & Application.PathSeparator Else MsgBox "You did not select a folder." Exit Sub End If End With With fd .Title = "Select the folder that contains the revised files." If .Show = -1 Then strRPath = .SelectedItems(1) & Application.PathSeparator Else MsgBox "You did not select a folder." Exit Sub End If End With With fd .Title = "Select the folder where the comparison files will be saved." If .Show = -1 Then strCPath = .SelectedItems(1) & Application.PathSeparator Else MsgBox "You did not select a folder." Exit Sub End If End With Set wd = GetObject(, "Word.Application") If wd Is Nothing Then Set wd = CreateObject("Word.Application") End If ReDim Preserve ofiles(0) 'Create a new document for the tracked changes, base on Normal.dot Set oNewDoc = Documents.Add 'Set orientation and borders, and add a table oNewDoc.PageSetup.Orientation = wdOrientLandscape With oNewDoc .Content = "" With .PageSetup .LeftMargin = CentimetersToPoints(2) .RightMargin = CentimetersToPoints(2) .TopMargin = CentimetersToPoints(2.5) End With End With 'Adjust the Normal style and Header style With oNewDoc.Styles(wdStyleNormal) With .Font .Name = "Arial" .Size = 9 .Bold = False End With With .ParagraphFormat .LeftIndent = 0 .SpaceAfter = 0 End With End With With oNewDoc.Styles(wdStyleHeader) .Font.Size = 8 .ParagraphFormat.SpaceAfter = 0 End With 'Add text that identifies the folder paths that were checked Selection.Style = ActiveDocument.Styles("Heading 1") Selection.TypeText text:="Tracked Changes Summary Report" Selection.TypeParagraph Selection.Font.Bold = wdToggle Selection.TypeText text:="Original: " & vbTab Selection.Font.Bold = wdToggle Selection.TypeText text:=strOPath Selection.TypeParagraph Selection.Font.Bold = wdToggle Selection.TypeText text:="Revised: " & vbTab Selection.Font.Bold = wdToggle Selection.TypeText text:=strRPath Selection.TypeParagraph Selection.TypeParagraph 'Add table with 3 columns With oNewDoc Set oTable = .Tables.Add _ (Range:=Selection.Range, _ numrows:=1, _ NumColumns:=3) End With 'Set a style for the table and set widths With oTable .Range.Style = wdStyleTableLightShadingAccent1 .AllowAutoFit = False .PreferredWidthType = wdPreferredWidthPercent .PreferredWidth = 100 For Each oCol In .Columns oCol.PreferredWidthType = wdPreferredWidthPercent Next oCol .Columns(1).PreferredWidth = 60 'Document .Columns(2).PreferredWidth = 25 'Status .Columns(3).PreferredWidth = 15 'Count End With 'Insert table headings With oTable.Rows(1) .Cells(1).Range.text = "Document" .Cells(2).Range.text = "Status" .Cells(3).Range.text = "Count" End With 'Generate the tracked changes comparisons (Note: Footnotes set to False to avoid all documents having changes due to different date/times the documents were generated) strORTFfile = Dir(strOPath & "\" & ("*.rtf"), vbNormal) Do While strORTFfile <> Empty ReDim Preserve ofiles(UBound(ofiles) + 1) ofiles(UBound(ofiles)) = strORTFfile strORTFfile = Dir Loop For i = 1 To UBound(ofiles) If Dir(strRPath & "\" & ofiles(i)) <> Empty Then Set oDoc = wd.Documents.Open(strOPath & "\" & ofiles(i)) Set rdoc = wd.Documents.Open(strRPath & "\" & ofiles(i)) Set ndoc = Application.CompareDocuments(OriginalDocument:=oDoc, _ RevisedDocument:=rdoc, _ Destination:=wdCompareDestinationNew, _ Granularity:=wdGranularityWordLevel, _ CompareFormatting:=True, _ CompareCaseChanges:=True, _ CompareWhitespace:=True, _ CompareTables:=True, _ CompareHeaders:=True, _ CompareFootnotes:=False, _ CompareTextboxes:=True, _ CompareFields:=True, _ CompareComments:=True, _ CompareMoves:=True, _ RevisedAuthor:="Elisa Young", _ IgnoreAllComparisonWarnings:=False) ofiles(i) = Replace(ofiles(i), Chr(13), "") ChDir strCPath ndoc.SaveAs2 FileName:=ofiles(i), _ FileFormat:=wdFormatRTF, LockComments:=False, _ Password:="", AddToRecentFiles:=True, WritePassword:="", _ ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False, CompatibilityMode:=0 ' Get info from each tracked change (insertion/deletion) from oTCDoc and insert in table Set oTCDoc = ActiveDocument If oTCDoc.Revisions.Count = 0 Then Set oRow = oTable.Rows.Add With oRow .Cells(1).Range.text = ndoc .Cells(1).Range.Font.TextColor = wdColorBlack .Cells(2).Range.text = "No Change" .Cells(2).Range.Font.TextColor = wdColorBlack End With Else Set oRow = oTable.Rows.Add With oRow .Cells(1).Range.text = oTCDoc .Cells(1).Range.Font.TextColor = wdColorBlack .Cells(2).Range.text = "Updates" .Cells(2).Range.Font.TextColor = wdColorRed .Cells(3).Range.text = oTCDoc.Revisions.Count .Cells(3).Range.Font.TextColor = wdColorRed End With End If 'Save the new summary report oNewDoc.SaveAs2 FileName:=strCPath & "\Tracked Changes Summary Report.docx", _ FileFormat:=wdFormatDocumentDefault 'Close all documents except the new summary report ActiveWindow.ShowSourceDocuments = wdShowSourceDocumentsNone ActiveWindow.Visible = False oTCDoc.Close savechanges = False rdoc.Close savechanges = False oDoc.Close savechanges = False End If Next End Sub |
Tags |
batch processing, compare documents, summary tasks |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
batch compare word file | maimi23 | Word VBA | 1 | 09-23-2021 04:21 AM |
Batch merging of Word documents | Harry Gateaux | Word VBA | 6 | 11-19-2020 09:58 AM |
Batch Editing Word documents | sakhtar6 | Word VBA | 6 | 03-02-2020 02:49 PM |
Batch create Word documents | cdfj | Word VBA | 6 | 11-07-2012 01:03 PM |
Can you compare two word documents? (Automatically) | admin4ever | Word | 2 | 05-17-2011 09:44 AM |