Microsoft Office Forums - View Single Post - [Solved] Multiple Files

macropod · 10-05-2017, 04:17 PM

Try the following macro. It should be saved in a new macro-enabled (docm) document in the same folder as the original mailmerge main documents. When you've created the Excel Project Data File for the project (assumed to be named 'ProjectDataFile.xlsx' for all projects), simply run the macro and let it create the 100 or so project documents with the merged output in the same folder that Excel file is in. The macro includes a folder browser, so all you need do is select the folder containing the Excel file.

With this approach, there's no need to copy all 100 or so mailmerge main documents, individually link them to the Excel file, merge to a new file, and so on. All you might need to do after running the macro is to delete any unwanted output documents for the particular project.

Code:

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

For PC macro installation & usage instructions, see: http://www.gmayor.com/installing_macro.htm