Sub merge1record_at_a_time() '
' merge1record_at_a_time Macro
' Adapted from:
'http://www.mrexcel.com/forum/general-excel-discussion-other-questions/713478-word-2007-2010-mail-merge-save-individual-pdf-files.html
Dim fd As FileDialog
'Create a FileDialog object as a Folder Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
'Use the Show method to display the Folder Picker dialog box and return the user's action.
'The user pressed the button.
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
'vrtSelectedItem is aString that contains the path of each selected item.
'You can use any file I/O functions that you want to work with this path.
'This example displays the path in a message box.
selectedpath = vrtSelectedItem
Next vrtSelectedItem
Else
MsgBox ("No Directory Selected. Exiting")
Exit Sub
End If
End With
'Set the object variable to Nothing.
Set fd = Nothing
Application.ScreenUpdating = False
mainDoc = ActiveDocument.Name
ChangeFileOpenDirectory selectedpath
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstDataSourceRecord
For i = 1 To ActiveDocument.MailMerge.DataSource.RecordCount
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
'moved the .ActiveRecord to just before the Next i
docname = .DataFields("Site").Value & ".pdf" ' ADDED CODE
End With
.Execute Pause:=False
Application.ScreenUpdating = False
End With
'This next code is used if you want Word documents.
' ActiveDocument.SaveAs FileName:=docName, FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
'This next code is used if you want PDF documents.
'set OpenAfterExport to False so the PDF files won't open after mail merge
ActiveDocument.ExportAsFixedFormat OutputFileName:=docname, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
'Windows(mainDoc).Activate (works for us WITH pdfS when this is commented out - ConnDublin
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextDataSourceRecord
Next i
Application.ScreenUpdating = True
End Sub
