Message in a bottle_WORD2010 VBA_Combination of track changes reviews into one document

[winrow]

Dear all,

That might be more a message in a bottle because WORD VBA is not the most looked for but I take my chance on this active forum.

What I would like to do: I sent a WORD2010 document into review and I collect the reviews from my colleagues as track changes. I would like to combine all track changes versions into one document (not combine one after another) when I call the macro from the original document that has been sent into review. The combine option review from Word2010 becomes readily limited when you have more than 5 documents. You understood me as a person always looking to sharpen my tools to avoid reptitive task

Ok so here I look around on VBAexpress FORUM, MSDN forums as Stackoverflow forum. I assembled bits of code and - yes - this is not working

Sub mergeTrackChanges()

'variables will change
Dim strFile as String, strFolder as String
Dim Count as Long
Dim i as integer
Dim v() as String
Dim files as String

'Let's open the folder that contains all track changes reviewed documents
'This part works fine

With Application.FileDialog(msoFileDialogFolderPicker)[INDENT].Title = "Pick your favorite folder for magic macro to happen"
.AllowMultiSelect = True[/INDENT]
[INDENT]
If .Show Then[/INDENT]
[INDENT=2] strFolder=.SelectedItems(1) & Application.PathSeparator[/INDENT]
[INDENT]Else[/INDENT]
[INDENT=4][/INDENT]
[INDENT=2]Exit Sub[/INDENT]
[INDENT]End if

[/INDENT]
End With

Count=0
strFile = Dir$(strFolder & "*.doc*")

' this is the bit of code that doesn't work. I also suspect I should include in the above with...If statement

v=Split(files,vbCr)
For i=1 to UBound(v)
[INDENT=2][/INDENT]
[INDENT]ActiveDocument.Merge FileName:= v(i), _
Mergetarget:=wdMergeTargetCurrent, DetectFormatChanges:=True, _
UseFormattingFrom:=wdFormattingFromCurrent, addtorecentfiles:=False

DoEvents[/INDENT]

Next i

End Sub

This is ugly - I know - and I will be grateful for any help provided. I also read that I might need .Collapse and .MainDoc.Range but really no clue

That's it for my bottle

 

[winrow]

I cannot count the number of hours I spent looking for an answer. I have to post something here and request for help to find one several hours later. Many thanks to http://www.vbforums.com/showthread....d-How-to-automate-Compare-amp-Merge-Documents

 

[Macropod]

You might try:

Sub MergeRevisions()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
Set wdDoc = ActiveDocument
strDocNm = wdDoc.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    wdDoc.Merge FileName:=strFolder & "\" & strFile, _
      MergeTarget:=wdMergeTargetCurrent, DetectFormatChanges:=True, _
      UseFormattingFrom:=wdFormattingFromCurrent, AddToRecentFiles:=False
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

 

[winrow]

Thanks macropod it works! I will look more in depth tomorrow with different real life situations that happened to me to verify that everything is correctly merged. I will keep you posted. I already have a preference for your code that is shorter

 

[winrow]

You might try:

Sub MergeRevisions()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
Set wdDoc = ActiveDocument
strDocNm = wdDoc.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    wdDoc.Merge FileName:=strFolder & "\" & strFile, _
      MergeTarget:=wdMergeTargetCurrent, DetectFormatChanges:=True, _
      UseFormattingFrom:=wdFormattingFromCurrent, AddToRecentFiles:=False
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

hi Paul,

As promised I had the opportunity to apply your code to my real-life examples. I noticed that if this correctly merges the documents, there are slight shifts in words/text, especially in the case of characters \% etc.
when using the macro recorder with the native word combine documents function the method application.mergedocument appears to preserve the granularity by word etc. Is there any possibility to amend your code using the .mergedocument ?

Again many thanks in advance for your help!

 

[Macropod]

To do it that way, you could use:

Sub MergeRevisions()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String
Dim wdDocSrc As Document, wdDocTgt As Document
Set wdDocTgt = ActiveDocument
strDocNm = wdDocTgt.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDocSrc = Documents.Open(strFolder & "\" & strFile, ReadOnly:=True, _
      AddToRecentFiles:=False, Visible:=False)
    Application.MergeDocuments OriginalDocument:=wdDocTgt, RevisedDocument:=wdDocSrc, _
      Destination:=wdCompareDestinationOriginal, Granularity:=wdGranularityWordLevel, _
      CompareFormatting:=True, CompareCaseChanges:=True, CompareWhitespace:=True, _
      CompareTables:=True, CompareHeaders:=True, CompareFootnotes:=True, _
      CompareTextboxes:=True, CompareFields:=True, CompareComments:=True, _
      CompareMoves:=True, FormatFrom:=wdMergeFormatFromPrompt
    wdDocSrc.Close SaveChanges:=False
  End If
  strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

 

[winrow]

To do it that way, you could use:

Sub MergeRevisions()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String
Dim wdDocSrc As Document, wdDocTgt As Document
Set wdDocTgt = ActiveDocument
strDocNm = wdDocTgt.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDocSrc = Documents.Open(strFolder & "\" & strFile, ReadOnly:=True, _
      AddToRecentFiles:=False, Visible:=False)
    Application.MergeDocuments OriginalDocument:=wdDocTgt, RevisedDocument:=wdDocSrc, _
      Destination:=wdCompareDestinationOriginal, Granularity:=wdGranularityWordLevel, _
      CompareFormatting:=True, CompareCaseChanges:=True, CompareWhitespace:=True, _
      CompareTables:=True, CompareHeaders:=True, CompareFootnotes:=True, _
      CompareTextboxes:=True, CompareFields:=True, CompareComments:=True, _
      CompareMoves:=True, FormatFrom:=wdMergeFormatFromPrompt
    wdDocSrc.Close SaveChanges:=False
  End If
  strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

it worked like a charm!

cosmetic modification to include docx and doc files

strFile = Dir(strFolder & "\*.doc*", vbNormal)

thanks a million, boredom repetitive work is now lightning fast! I also could have a peek at word vba and learn

 

[Macropod]

Your cosmetic modification shouldn't be needed.

 

[winrow]

Your cosmetic modification shouldn't be needed.

Strange because when I ran the macro with .doc it was not opening any of my revised docx documents.

idk if this comes from my word version or the one from the reviewers (2010 and above). I will keep a close look on future instances and compare with manual merges (word built in compare function)

Cheers