I want to share this with you in case you ever need to redact sensitive words from a word document. You make a space delimited dotx document with the words to redact. If it contains words that are not in the document its not a problem. You edit the macro to give the location and name of your word list. You then make the document to be redacted the current document and run the macro. Sensitive words are replaced by a grey felt tip pen line of fixed length. Nothing else is altered.
Code:
Sub Redact()
'
' Redact Macro
' Redacts any words listed in sWordListDoc (see right after Application.ScreenUpdating = False )
' from the currently open .dotx file by replacing those words by a 'grey felt tip pen' mark
' Once run check and save. Future readers cannot get to the original text or see its length.
Dim sWordListDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object
Application.ScreenUpdating = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sWordListDoc = "C:\Users\..........WordList.dotx" 'edit this to the location of your WordList.dotx or whatever you have called it.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
With .Replacement.Font
.Italic = True
.ColorIndex = wdGray25 'pale grey
.Size = 10
.Name = "Webdings"
End With
.Replacement.Text = "gggg" ' = 4 squares in Webdings font
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = True
.MatchWildcards = False
End With
For Each wrdRef In docRef.Words
If Asc(Left(wrdRef, 1)) > 32 Then
With Selection.Find
.Wrap = wdFindContinue
.Text = wrdRef
.Execute Replace:=wdReplaceAll
End With
End If
Next wrdRef
Application.ScreenUpdating = True
docRef.Close
docCurrent.Activate
End Sub