#1
|
|||
|
|||
Automate mail merge to save each record individually using VBA
Hi,
I am trying to automate mail merge to save each record individually using VBA. I know there are a lot of guides and tutorials out there, I have tried a few and had no luck. The best success I've had so far is the code below, pulled from HTML Code:
https://swissmacuser.ch/microsoft-word-mail-merge-into-single-documents/ This currently works to export a document from mail merge and save as individual file, it just appears to save the same document over the top of each other. E.g. I will end up with only one merged document at the end as the others were saved over during the process. I can see in preview mode when I run the macro, the file saving over itself and updating content. Here is my code:
|
#2
|
||||
|
||||
The following will work, however may I suggest you look at the merge to documents mode of E-Mail Merge Add-in
Code:
Option Explicit Sub SaveIndividualWordFiles() Dim i As Long Dim docMail As Document Dim docLetters As Document Dim savePath As String, sFName As String Set docMail = ActiveDocument savePath = docMail.path & "\" With docMail.MailMerge For i = 1 To .DataSource.RecordCount .Destination = wdSendToNewDocument .SuppressBlankLines = True With .DataSource .FirstRecord = i .LastRecord = i .ActiveRecord = i '' This will be the file name '' the test data source had unique surnames '' in a field (column) called FileName sFName = .DataFields("Title").value End With .Execute Pause:=False Set docLetters = ActiveDocument ' Save generated document and close it after saving docLetters.SaveAs FileName:=savePath & sFName & ".docx" docLetters.Close False DoEvents Next End With Set docMail = Nothing Set docLetters = Nothing End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
@gmayor
I have tried the code you posted with no success. Using step into, it gets to "For i = 1 To .DataSource.RecordCount" and moved straight to "End With" Any thoughts or advice? Unfortunately I don't have to option to install an Add-in for this. |
#4
|
||||
|
||||
See Send Mailmerge Output to Individual Files in the Mailmerge Tips & Tricks 'Sticky' thread at the top of the Mailmerge forum: https://www.msofficeforums.com/mail-...ps-tricks.html
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
This VBA did not work for me. When I run the macro, nothing happens.
|
#6
|
||||
|
||||
Dis you have a datasource attached to the merge document?
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#7
|
|||
|
|||
Yes, example data source attached and merge template attached.
|
#8
|
||||
|
||||
If the data sheet was viable (It has an incompatible ROW1 and several empty rows after the sixth record) and you remove the unassociated field from the document then save it as a DOCX format (see attached) the code I posted works without problem. See attached. You'll need to reattach the data file.
Run the code from your normal template.
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#9
|
|||
|
|||
I am still having some trouble. I have had 2 outcomes:
1. When I first connect the data source and run the macro I have to run it 3-4 times and it either exports 1,2 or 3 files (screen recording attached) 2. When I delete those saved files from the folder (Created above) and I run the macro, I can see the preview of the file exporting all of the different data and saving the file on top of itself (screen recording attached), so I only end up with one file. Any thoughts on why this might be? |
#10
|
||||
|
||||
If the field chosen for the filename contains the same data for multiple records then of course the documents will be overwritten by subsequent records. The sample data you provided has different data in each record in the Title field and so produces six documents.
If you want to account for duplicate names, you need a lot more code. You will also need to test for illegal filename characters (there were none in your Title field example) and it is probably wider to use a subfolder to save the merged documents. The following does that also. Code:
Option Explicit Sub SaveIndividualWordFiles() Dim i As Long Dim docMail As Document Dim docLetters As Document Dim savePath As String, sFName As String Set docMail = ActiveDocument savePath = docMail.path & "\Merged Documents\" CreateFolders savePath With docMail.MailMerge For i = 1 To .DataSource.RecordCount .Destination = wdSendToNewDocument .SuppressBlankLines = True With .DataSource .FirstRecord = i .LastRecord = i .ActiveRecord = i sFName = .DataFields("Title").value sFName = CleanFilename(sFName) sFName = FileNameUnique(savePath, sFName, "docx") End With .Execute Pause:=False Set docLetters = ActiveDocument docLetters.SaveAs FileName:=savePath & sFName & ".docx" docLetters.Close False DoEvents Next End With Set docMail = Nothing Set docLetters = Nothing End Sub Private Function CleanFilename(strFileName As String) As String Dim arrInvalid() As String Dim lng_Index As Long 'Define illegal characters (by ASCII CharNum) arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|") 'Remove any illegal filename characters CleanFilename = strFileName For lng_Index = 0 To UBound(arrInvalid) CleanFilename = Replace(CleanFilename, Chr(arrInvalid(lng_Index)), Chr(95)) Next lng_Index lbl_Exit: Exit Function End Function Private Function FileNameUnique(strPath As String, _ strFileName As String, _ strExtension As String) As String 'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018 'strPath is the path in which the file is to be saved 'strFilename is the filename to check 'strExtension is the extension of the filename to check Dim lng_F As Long Dim lng_Name As Long Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") Do Until Right(strPath, 1) = "\" strPath = strPath & "\" Loop If InStr(1, strFileName, "\") > 0 Then strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1) End If strExtension = Replace(strExtension, Chr(46), "") lng_F = 1 If InStr(1, strFileName, strExtension) > 0 Then lng_Name = Len(strFileName) - (Len(strExtension) + 1) Else lng_Name = Len(strFileName) End If strFileName = Left(strFileName, lng_Name) 'If the filename exists, add or increment a number to the filename 'and keep checking until a unique name is found Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")" lng_F = lng_F + 1 Loop 'Reassemble the filename FileNameUnique = strFileName lbl_Exit: Set FSO = Nothing Exit Function End Function Private Sub CreateFolders(strPath As String) 'A Graham Mayor/Greg Maxey AddIn Utility Macro Dim oFSO As Object Dim lng_PathSep As Long Dim lng_PS As Long If Right(strPath, 1) <> "\" Then strPath = strPath & "\" lng_PathSep = InStr(3, strPath, "\") If lng_PathSep = 0 Then GoTo lbl_Exit Set oFSO = CreateObject("Scripting.FileSystemObject") Do lng_PS = lng_PathSep lng_PathSep = InStr(lng_PS + 1, strPath, "\") If lng_PathSep = 0 Then Exit Do If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do Loop Do Until lng_PathSep = 0 If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then oFSO.CreateFolder Left(strPath, lng_PathSep) End If lng_PS = lng_PathSep lng_PathSep = InStr(lng_PS + 1, strPath, "\") Loop lbl_Exit: Set oFSO = Nothing Exit Sub End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#11
|
|||
|
|||
Thank you for the extra detailed code.
There were no repeat file names or illegal file names. I used the same sample data to test and screen record. There must be something odd with my computer not running it if it worked on your computer. I will test on windows in the office and report back - that might be the issue (currently testing on Mac (and remembering to change file path to / from \)) The longer code also didn't seem to register on my mac. Running macro just did nothing. Didn't run an error or anything. Hopefully the shorter version will work on windows, if not I will try this out. Thanks for your help so far - much appreciated. |
#12
|
||||
|
||||
Your profile indicates that you are using Windows 10 and Office 2019. Non code is not tested on a Mac and may not work with that operating system.
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#13
|
|||
|
|||
Ask
Hi, if i want to save file name with 2 criteria to avoid double, how should it be?
|
#14
|
||||
|
||||
Simply include both data fields in the sFName variable...
For example: sFName = .DataFields("Surname").Value & ", " & .DataFields("Namee").Value
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#15
|
||||
|
||||
ahdiethya: Kindly don't ask the same question in multiple threads. You also posted here: https://www.msofficeforums.com/word-...eria-mail.html
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
mail merge, mail merge code, mail merge saving |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to mail merge next record on same page to save paper | klc9761 | Mail Merge | 1 | 04-22-2017 02:29 PM |
Showing record number during mail merge | catflap | Mail Merge | 1 | 04-13-2017 07:32 AM |
Mail Merge Next Record If rule | RHensley | Mail Merge | 10 | 03-07-2017 08:05 AM |
Automate daily mail merge | JCInfo | Mail Merge | 4 | 12-02-2013 05:12 PM |
avoid duplicete record and merge the record with the existed record | hemant.behere | Excel | 0 | 01-10-2012 02:53 AM |