Microsoft Office Forums - View Single Post - Macro to replace SSN in all files within a folder

macropod · 08-28-2014, 09:10 PM

It would be better to do this when the documents are generated, not afterwards. If they are being generated via mailmerge, for example, field coding can be used to output XXX-XX- plus only the last four digits.

That said, the following macro will process all documents in the selected folder:

Code:

Sub BulkReplaceSSNs()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc.Range.Find
    .ClearFormatting
    .Text = "([0-9]{3})-([0-9]{2})-([0-9]{4})"
    .Replacement.Text = "XXX-XX-\3"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  wdDoc.Close SaveChanges:=True
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

The macro includes its own browser, so all you need do is select the folder to process, and let it run. Just be sure to not save the document you're running the macro from to the same folder.