Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim Sctn As Section, HdFt As HeaderFooter, Shp As Shape
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
    'Process the body
    Call Update(.Range)
    'Process textboxes etc in the body
    For Each Shp In .Shapes
      With Shp.TextFrame
        If .HasText Then
          Call Update(.TextRange)
        End If
      End With
    Next
    For Each Sctn In .Sections
      For Each HdFt In Sctn.Headers
        With HdFt
          If .LinkToPrevious = False Then
            'Process the header
            Call Update(.Range)
          End If
        End With
      Next
    Next
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Sub Update(Rng As Range)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "04-15-09"
  .Replacement.Text = "05-05-14"
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .Execute Replace:=wdReplaceAll
End With
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