Option Explicit
Sub MailMerge()
'Word application objects declaration
' Important:
' Set Reference (Tools menu) to Microsoft Word nn.n Object Library
Dim oApp As Word.Application
Dim oDoc As Word.Document
Dim oTemplate As Word.Document
Dim oBookMark As Word.Bookmark
' Excel application objects declaration
Dim strOutputFilename As String ' <===== New line of code
Dim wb As Workbook
Dim ws As Worksheet
Dim wsControl As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim objX As Object
Dim strDocName As String
Dim strPathName As String
Dim lngKount As Long
Dim lngRecordKount As Long
Dim strFileName As String
'
On Error GoTo HandleError
'
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Merge Data")
Set wsControl = wb.Worksheets("Control Sheet")
'Set data range
' Records in Column A, excluding heading
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(65536, 1).End(xlUp))
lngRecordKount = rng.Rows.Count
' Get location of WORD document:
strPathName = wsControl.Range("B1").Value
strDocName = wsControl.Range("B2").Value
If ((strDocName = "") Or (strDocName = " ")) Then
' use document with same name as this workbook:
strDocName = Left(wb.Name, Len(wb.Name) - 4) & ".doc"
End If
If ((strPathName = "") Or (strPathName = " ")) Then
' use same path as this workbook:
strPathName = wb.Path
End If
strFileName = strPathName & "\" & strDocName
' Check that file exists:
If Dir(strFileName) = "" Then
MsgBox strFileName & vbCrLf & "cannot be found", vbOKOnly + vbCritical, "Error"
GoTo HandleExit
End If
'Create new word application
Application.StatusBar = "Starting Microsoft Word"
Set oApp = CreateObject("Word.Application")
'Loop in data range
lngKount = 1
For Each rng2 In rng.Cells
Application.StatusBar = "Creating document " & lngKount & " of " & lngRecordKount
'Create new document
'Application.StatusBar = "Creating new Word Document" <===== No longer required
Set oDoc = oApp.Documents.Add ' <===== moved here
oApp.Selection.InsertFile strFileName
'Find all bookmarks and replace with data:
For Each oBookMark In oDoc.Bookmarks
'Corresponding header found in first row ?
Set objX = ws.Rows(1).Find(oBookMark.Name, LookIn:=xlValues, LookAt:=xlWhole)
If Not objX Is Nothing Then
' heading found for bookmark
oBookMark.Range.Text = rng2.Offset(, objX.Column - 1).Value
Else
MsgBox "Error - Bookmark '" & oBookMark.Name & "' not found in " & vbCrLf & _
"[" & wb.Name & "]!" & wsControl.Name & vbCrLf & vbCrLf & _
"Please check that all bookmarks exist as headings", vbOKOnly, "Bookmark Error"
oApp.Quit
GoTo HandleExit
End If
Next oBookMark
'Goto next page
'wdPageBreak = 7
' oApp.Selection.InsertBreak 7 <===== No longer required
strOutputFilename = ws.Cells(rng2.Row, 4) ' <===== New line of code
oDoc.SaveAs (strOutputFilename) ' <===== New line of code
' (the "4" refers to column containing the output filename in MY workbook and should be changed)
oDoc.Close ' <===== New line of code
lngKount = lngKount + 1
Next rng2
'
MsgBox "Process complete - please check result", vbOKOnly + vbInformation, "Merge Complete"
' oApp.Visible = True <===== Not required in the code revision
HandleExit:
On Error Resume Next
oApp.Quit ' <===== New line of code
Application.StatusBar = ""
Application.ScreenUpdating = True
Set oDoc = Nothing
Set oTemplate = Nothing
Set oBookMark = Nothing
Set wb = Nothing
Set ws = Nothing
Set wsControl = Nothing
Set rng = Nothing
Set rng2 = Nothing
Set objX = Nothing
'
Set oApp = Nothing
'
Exit Sub
'
HandleError:
' Do something here?
Resume HandleExit
End Sub
