A better ‘anonymize a Word document’ solution

Office for Mere Mortals
Your beginners guide to the secrets of Microsoft Office
Invalid email address
Give it a try. You can unsubscribe at any time.

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

 

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

Want More?

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