MailMerge from VBA Excel to Word

morand13 · Sep 12th 2017

Hi All,
I need help with the following code. I have two documents - one excel document which has the source data (Sheet = FirmOffers) for a mail merge i want to automate in Word. I have my merge fields set up in the attached word docx (Test.docx). I have also the excel file attached (LettersAutomation.xlsm) which has the code. I want to save each mail merge record in word - 1st as a word doc and then as a PDF doc. A document called 'Form Letters1' is created and this is the document i want to save as it has the 1st merged records displayed. However, the save does work the 1st time round but it saves the word document that is not merged (Test.docx). The error message then appears saying that Test.docx is locked for editing.

Code

Public Sub MailMergeCert()




Dim bCreatedWordInstance As Boolean




Set objWord = CreateObject("Word.Application")
Set objMMMD = objWord.Documents.Open("\\C:\Users\0104415s\Google Drive\New System\Letter Automation\Test.docx")
objMMMD.Activate
objWord.Visible = True




Dim Address As String
Dim FirstName As String
Dim CourseDescription As String
Dim AppNo As String








Dim r As Long
Dim ThisFileName As String




Set sh1 = Sheets("FirmOffers")




lastrow = Sheets("FirmOffers").Range("A" & Rows.Count).End(xlUp).Row
r = 2




For r = 2 To lastrow
If IsEmpty(Cells(r, 32).Value) = False Then GoTo nextrow




FirstName = sh1.Cells(r, 16).Value
Surname = sh1.Cells(r, 15).Value
CourseDescription = sh1.Cells(r, 6).Value
AppNo = sh1.Cells(r, 2).Value
Address = sh1.Cells(r, 19).Value








' Setup directories
cDir = ActiveWorkbook.Path + "\" 'Change if required
ThisFileName = ThisWorkbook.Name




On Error Resume Next




' Create a Word Application instance
bCreatedWordInstance = False
Set objWord = GetObject(, "Word.Application")




If objWord Is Nothing Then
  Err.Clear
  Set objWord = CreateObject("Word.Application")
  bCreatedWordInstance = True
End If




If objWord Is Nothing Then
MsgBox "Could not start Word"
Err.Clear
On Error GoTo 0
Exit Sub
End If




' Let Word trap the errors
On Error GoTo 0




objWord.Visible = False








'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir + ThisFileName, SQLStatement:="SELECT *  FROM `FirmOffers$`"[B]   ' if i continue to open read-only doc, debug highlights this line here[/B]


With objMMMD.MailMerge  'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
  .FirstRecord = r - 1
  .LastRecord = r - 1
  .ActiveRecord = r - 1
   
End With
.Execute Pause:=False




End With




End With




 ' Save new file
'Path and YYMM
Dim PeriopCertPath As String
PeriopCertPath = "C:\Users\0104415s\Google Drive\New System\Letter Automation\"
Dim YYMM As String
YYMM = Format(sh1.Cells(r, 10).Value, "YYMM")




'Word document
Dim NewFileNameWd As String




Set objWord = CreateObject("word.Application")
Set objMMMD = objWord.Documents.Open("\\C:\Users\0104415s\Google Drive\New System\Letter Automation\Test.docx") [B]'if i cancel to open read-only doc - debugs highlights this line[/B]
objMMMD.Activate
objWord.Visible = True




NewFileNameWd = sh1.Cells(r, 2) & "_" & sh1.Cells(r, 15).Value & "_" & sh1.Cells(r, 16).Value & ".docx" 'Change File Name as req'd"
objWord.ActiveDocument.SaveAs2 Filename:=PeriopCertPath & NewFileNameWd, FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False, CompatibilityMode:=15








'PDF
Dim NewFileNamePDF As String
NewFileNamePDF = sh1.Cells(r, 2) & "_" & sh1.Cells(r, 15).Value & "_" & sh1.Cells(r, 16).Value '& ".pdf" 'Change File Name as req'd"




objWord.ActiveDocument.ExportAsFixedFormat PeriopCertPath & NewFileNamePDF, ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False




        
' Close the Mail Merge Main Document
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing




' Close the New Mail Merged Document
If bCreatedWordInstance Then
objWord.Quit
End If




0:
Set objWord = Nothing
Cells(r, 10).Value = Date
nextrow:




Next r








End Sub

Display More

**Kenneth Hobson** · Sep 12th 2017

Re: MailMerge from VBA Excel to Word

Does this help?

Code

'If Word found locked fields shows after a merge, see this workaround:
'http://support.microsoft.com/kb/292155 - due to inline text in Autoshape layout.


'Requires Tools > References > Microsoft Word xx.0 Object Library
Sub MergeRun(frmFile As String, datFile As String, _
  SQL As String, _
  Optional bClose As Boolean = False, Optional bPrint As Boolean = False, _
  Optional iNoCopies As Integer = 1)
  
  Dim wdApp As Word.Application
  Dim myDoc As Word.Document
  
  'Tell user what file is missing and exit.
  If Dir(frmFile) = "" Then
    MsgBox "Form file does not exist." & vbLf & frmFile, _
      vbCritical, "Exit - Missing Form File"
  End If
  If Dir(datFile) = "" Then
    MsgBox "Data file does not exist." & vbLf & datFile, _
      vbCritical, "Exit - Missing Data File"
  End If
  If Dir(frmFile) = "" Or Dir(datFile) = "" Then Exit Sub
  
  On Error Resume Next
  Set wdApp = GetObject(, "Word.Application")
  If Err.Number <> 0 Then
      Set wdApp = CreateObject("Word.Application")
  End If
  On Error GoTo errorHandler
  
  With wdApp
   On Error GoTo errorHandler
    wdApp.Application.DisplayAlerts = wdAlertsNone
    
    'Open form file and associate data file
    Set myDoc = .Documents.Open(frmFile, False, True, False)
    .ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    .ActiveDocument.MailMerge.OpenDataSource Name:=datFile, _
      ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=False, _
      AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
      WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
      Format:=wdOpenFormatAuto, Connection:="", SQLStatement:=SQL, SQLStatement1 _
      :="", SubType:=wdMergeSubTypeOther
    'Merge to a new document
    With wdApp.ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With
    .Visible = True
    
    If bPrint = True Then
      .Application.PrintOut Filename:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentContent, Copies:=iNoCopies, Pages:="", PageType:=wdPrintAllPages, _
        ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
        False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
    End If
    
    If bClose = True Then
      .ActiveDocument.Close False
      .ActiveDocument.Close False
    End If


    wdApp.Application.DisplayAlerts = wdAlertsAll
  End With
     
errorExit:
    On Error Resume Next
    myDoc.Close False
    Set myDoc = Nothing
    Set wdApp = Nothing
    Exit Sub
 
errorHandler:
    MsgBox "Unexpected error: " & Err.Number & vbLf & Err.Description
    Resume errorExit
End Sub

Display More

MailMerge from VBA Excel to Word

Participate now!

Share