A better ‘anonymize a Word document’ solution


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.  As we type this, a reader has sent some code which handles capitalization and extended characters.  More on that soon.

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’.

 

1
Sub ReplaceWordswithFillerRegex()
1
'
1
' Separate Replace Regex commands to substitute words for filler words of the same length
1
' for word lengths from 1 to 20.
1
' from Office-Watch.com
1
'
1
    Dim FillerWord As String
1
    Dim i As Integer
1
   
1
    For i = 1 To 20 ' up to 20 letter words
1
   
1
    Select Case i  ' replacement words  FillerWord
1
       
1
       Case 1
1
          FillerWord = "a"
1
       Case 2
1
          FillerWord = "be"
1
       Case 3
1
          FillerWord = "sea"
1
       Case 4
1
          FillerWord = "dead"
1
       Case 5
1
          FillerWord = "ether"
1
       Case 6
1
          FillerWord = "fights"
1
       Case 7
1
          FillerWord = "generic"
1
       Case 8
1
          FillerWord = "heavenly"
1
       Case 9
1
          FillerWord = "indicator"
1
       Case 10
1
          FillerWord = "janitorial"
1
       Case 11
1
          FillerWord = "labyrinthian"
1
       Case 12
1
          FillerWord = "manifestation"
1
       Case 13
1
          FillerWord = "neighborliness"
1
       Case 14
1
          FillerWord = "oceanographical"
1
       Case 15
1
          FillerWord = "parliamentarian"
1
       Case 16
1
          FillerWord = "quadruplications"
1
       Case 17
1
          FillerWord = "reclassifications"
1
       Case 18
1
          FillerWord = "spectrographically"
1
       Case 19
1
          FillerWord = "transmogrifications"
1
       Case 20
1
          FillerWord = "uncharacteristically"
1
       Case Else ' should not reach this ... just in case
1
          FillerWord = "21LettersPlus"
1
    End Select ' i

 

1
      
1
        ' Clear any Find/Replace settings before we start
1
        Selection.Find.ClearFormatting
1
        Selection.Find.Replacement.ClearFormatting
1
          
1
        With Selection.Find
1
             .Text = "[a-zA-Z]{" &amp; Trim(Str(i)) &amp; "}" ' Words of i length
1
            .Replacement.Text = FillerWord
1
            .MatchWholeWord = True  ' important to select all and only words.
1
            .MatchWildcards = True  ' to make the RegEx work
1
            .Forward = True
1
            .Wrap = wdFindContinue
1
            .Format = False
1
            .MatchCase = False
1
            .MatchKashida = False
1
            .MatchDiacritics = False
1
            .MatchAlefHamza = False
1
            .MatchControl = False
1
            .MatchAllWordForms = False
1
            .MatchSoundsLike = False
1
        End With
1
       
1
        ' Enable these lines to highlight any changes made
1
        Options.DefaultHighlightColorIndex = wdYellow
1
        Selection.Find.Replacement.Highlight = True

 

1
        Selection.Find.Execute Replace:=wdReplaceAll

 

1
    Next ' i

 

1
' Digits - replace any digit with 9

 

1
    Selection.Find.ClearFormatting
1
    Selection.Find.Replacement.ClearFormatting
1
      
1
    With Selection.Find
1
        .Text = "[0-9]{1}"
1
        .Replacement.Text = "9"
1
        .Forward = True
1
        .Wrap = wdFindContinue
1
        .Format = False
1
        .MatchCase = False
1
        .MatchWholeWord = False
1
        .MatchKashida = False
1
        .MatchDiacritics = False
1
        .MatchAlefHamza = False
1
        .MatchControl = False
1
        .MatchAllWordForms = False
1
        .MatchSoundsLike = False
1
        .MatchWildcards = True
1
    End With
1
   
1
   
1
    ' Enable these two lines to highlight any changes made
1
    Options.DefaultHighlightColorIndex = wdYellow
1
    Selection.Find.Replacement.Highlight = True
1
   
1
    Selection.Find.Execute Replace:=wdReplaceAll

 

1
    End Sub

Want More?

Office Watch has the latest news and tips about Microsoft Office.  Delivered once a week.