Here’s some better VBA code for converting a private document (contract etc) into one with anonymous words. A useful trick if you’re trying to fix a Word formatting problem but can’t share the document. Legal numbering problems is a common issue that this macro can help with.
Office-Watch.com has already done a macro which replaces each letter with a random letter. And a manual way to replace with filler words of the same length.
The new version replaces each word with another of the same length, replaces all digits with 9 and highlights the changes. Here’s a document before and after.
All the changes are highlighted so you can quickly see what has been changed and anything which has been missed. Word’s standard Find/Replace doesn’t ‘see’ everything in a document with Header, Footer and Text Boxes missed. The highlighting helps you see any omissions.
Remove the highlighting, for easier viewing. Select All (Ctrl + A) then choose No Color from the highlighting list.
VBA code
The VBA code is below. As usual, we’ve deliberately made the code easy to understand as opposed to clever <g>.
Thanks to Rose and Lillie for their suggestions ….
More than one solution
There’s more than one way to handle this problem.
To replace all text including Headers, Footers, Text Boxes etc is surprisingly and ridiculously complicated. Have a look at this Word MVP page ‘Step 3’.
Sub ReplaceWordswithFillerRegex()
'
' Separate Replace Regex commands to substitute words for filler words of the same length
' for word lengths from 1 to 20.
' from Office-Watch.com
'
Dim FillerWord As String
Dim i As Integer
For i = 1 To 20 ' up to 20 letter words
Select Case i ' replacement words FillerWord
Case 1
FillerWord = "a"
Case 2
FillerWord = "be"
Case 3
FillerWord = "sea"
Case 4
FillerWord = "dead"
Case 5
FillerWord = "ether"
Case 6
FillerWord = "fights"
Case 7
FillerWord = "generic"
Case 8
FillerWord = "heavenly"
Case 9
FillerWord = "indicator"
Case 10
FillerWord = "janitorial"
Case 11
FillerWord = "labyrinthian"
Case 12
FillerWord = "manifestation"
Case 13
FillerWord = "neighborliness"
Case 14
FillerWord = "oceanographical"
Case 15
FillerWord = "parliamentarian"
Case 16
FillerWord = "quadruplications"
Case 17
FillerWord = "reclassifications"
Case 18
FillerWord = "spectrographically"
Case 19
FillerWord = "transmogrifications"
Case 20
FillerWord = "uncharacteristically"
Case Else ' should not reach this ... just in case
FillerWord = "21LettersPlus"
End Select ' i
' Clear any Find/Replace settings before we start
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[a-zA-Z]{" & Trim(Str(i)) & "}" ' Words of i length
.Replacement.Text = FillerWord
.MatchWholeWord = True ' important to select all and only words.
.MatchWildcards = True ' to make the RegEx work
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
End With
' Enable these lines to highlight any changes made
Options.DefaultHighlightColorIndex = wdYellow
Selection.Find.Replacement.Highlight = True
Selection.Find.Execute Replace:=wdReplaceAll
Next ' i
' Digits - replace any digit with 9
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[0-9]{1}"
.Replacement.Text = "9"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
' Enable these two lines to highlight any changes made
Options.DefaultHighlightColorIndex = wdYellow
Selection.Find.Replacement.Highlight = True
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
