Sub GenerateProjectDocuments()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Dim strFolder As String, StrSrc As String, strPath As String, strFile As String
Dim strDocNm As String, wdDoc As Document, FlFmt As Long
strDocNm = ActiveDocument.FullName: strPath = ActiveDocument.Path
strFolder = GetFolder: If strFolder = "" Then Exit Sub
StrSrc = strFolder & "\ProjectDataFile.xlsx"
strFile = Dir(strPath & "\*.doc", vbNormal)
While strFile <> ""
  If strPath & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strPath & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      FlFmt = .SaveFormat
      With .MailMerge
        .MainDocumentType = wdFormLetters
        .Destination = wdSendToNewDocument
        .OpenDataSource Name:=StrSrc, ReadOnly:=True, AddToRecentFiles:=False, LinkToSource:=False, _
          Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
          "Data Source=StrSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
          SQLStatement:="SELECT * FROM `Sheet1$`", SQLStatement1:="", SubType:=wdMergeSubTypeAccess
        .DataSource.ActiveRecord = wdFirstRecord
        .DataSource.LastRecord = .DataSource.ActiveRecord
        .Execute Pause:=False
      End With
      .Close SaveChanges:=False
    End With
    With ActiveDocument
      .SaveAs2 FileName:=strFolder & "\" & strFile, FileFormat:=FlFmt, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.DisplayAlerts = wdAlertsAll
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