VBA emulation of WinWord's file compare for strings - vba

Question

I'm replacing certain strings throughout a WinWord document with strings of a slightly different spelling with revision tracking being enabled.
Revision tracking will mark the whole original string as being deleted and the whole replacement string as being inserted. Anybody who is reviewing the text and wanting to know why a certain string has been replaced will have to visually compare both strings, even if they differ only in one or two characters.
I would much prefer if only the differing characters are being marked as revisions. That would probably mean that I have to emulate WinWords file compare function, albeit not for whole files but for strings within a given file. Has anybody already tried anything like that or a good idea of how to approach this task? (I know, it is possible to copy original and replacement string into 2 empty files, compare the files and use the result, but with hundreds of strings within a single file this is no practical solution.)

Answer 1

One way to do this is to be more selective in how you're actually replacing the words. The built in Find/Replace works by replacing the entire word, but by utilising VBA you can be more specific about what is being replaced. So we still use the built in Find function to identify the words to be replaced, but then you could iterate through each character in the word and compare against your replacement text therefore only replacing what is necessary. I've commented to below code to explain how an example of this would work.
This would produce output as in the below examples, only highlighting the actual characters that have been changed.
Sub replaceDifferencesOnly()
Dim findText As String: findText = "Analyze"
Dim replaceText As String: replaceText = "Analyse"
Dim found As Boolean: found = True
' Using the built-in 'Find' Function, loop through each instance of
' findText within the Document.
While found
With Selection.Find
.Text = findText
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
' If findText is found within the Document...
If Selection.Find.Execute = True Then
Dim match As Range
Dim char As Range
Dim position As Integer: position = 1
' Transfer the Selections Range into a seperate Range object.
Set match = Selection.Range
For Each char In match.Characters
Select Case Len(replaceText)
Case Is >= position
' If findText and replaceText are currently of an equal length...
' Simply compare and replace differing character.
If Not char.Text = Mid(replaceText, position, 1) Then
char.InsertBefore Mid(replaceText, position, 1)
' Inserting a Character will extend the size of the current 'character' or Range
' Move the start position of the range on so as to only delete the original unwanted character.
char.MoveStart
char.Delete wdCharacter
End If
Case Is < position
' If replaceText is shorter than findText...
' Simply delete the remaining unwanted characters in findText.
char.Delete
End Select
position = position + 1
Next char
If position <= Len(replaceText) Then
' Finally if replaceText is longer than findText ie. we've processed each original character in
' findText but there are still more characters in replaceText...
' Simply append the remaining characetrs within replaceText to the end of the Range
match.InsertAfter Mid(replaceText, position, (Len(replaceText) - position) + 1)
End If
Else
' No match from Find so exit the routine as there is nothing more to replace.
found = False
End If
Wend
' Clear the current Selected text.
Selection.Collapse
End Sub