I created a macro in Excel where I can mail-merge data from Excel into Word Letter Template and save the individual files in the folder.
I have Employee data in Excel and I can generate any Employee letter using that Data and can save the individual Employee letter as per the Employee name.
I have run mail-merge automatically and save individual files as per the Employee name. And every time it runs the file for one person it will give the status as Letter Already Generate so that it wont duplicate any Employee records.
The problem is the output in all the merged files the output is same as the first row. Example: if my Excel has 5 Employee details I am able to save the 5 individual merged files on each employee name, however the merged data if of the first employee who is in Row 2.
My rows have the below data:
Row A: has S.No.
Row B: has Empl Name
Row C: has Processing Date
Row D: has Address
Row E: Firstname
Row F: Business Title
Row G: Shows the status (if the letter is generated it shows "Letter Generated Already" after running the macro or it shows blank if it is new record entered.
Also how can I save the output (merged file) also in PDF other than DOC file so the merged files will be in two formats one in DOC and the other one in PDF formats?
Sub MergeMe()
Dim bCreatedWordInstance As Boolean
Dim objWord As Word.Application
Dim objMMMD As Word.Document
Dim EmployeeName As String
Dim cDir As String
Dim r As Long
Dim ThisFileName As String
lastrow = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
r = 2
For r = 2 To lastrow
If Cells(r, 7).Value = "Letter Generated Already" Then GoTo nextrow
EmployeeName = Sheets("Data").Cells(r, 2).Value
' Setup filenames
Const WTempName = "letter.docx" 'This is the 07/10 Word Templates name, Change as req'd
Dim NewFileName As String
NewFileName = "Offer Letter - " & EmployeeName & ".docx" 'This is the New 07/10 Word Documents File Name, Change as req'd"
' Setup directories
cDir = ActiveWorkbook.path + "\" 'Change if appropriate
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
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir + WTempName)
objMMMD.Activate
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir + ThisFileName, sqlstatement:="SELECT * FROM `Data$`" ' Set this as required
With objMMMD.MailMerge 'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
End With
' Save new file
objWord.ActiveDocument.SaveAs cDir + NewFileName
' 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, 7).Value = "Letter Generated Already"
nextrow:
Next r
End Sub
To save the file in pdf format use
objWord.ActiveDocument.ExportAsFixedFormat cDir & NewFileName, _
ExportFormat:=wdExportFormatPDF
It looks to me that when you are executing the mail merge, it should create a file with ALL of the letters, so when you open it, it would appear that the first letter is the one that is getting saved, but if you scroll down the word file that you have saved, you may find each letter on a new page.
Instead, you want to execute the merge one letter at a time.
To fix this, change the lines as follows:
With .DataSource
.FirstRecord = r-1
.LastRecord = r-1
.ActiveRecord = r-1
You need to use r-1 because Word is going to use the record number in its dataset, and since the data starts in row 2, and the counter r is related to the row, you need r-1.
You don't need to open up word each time, so put all of the code setting the datasource of the mail merge and creating the word doc outside of your main loop.
Const WTempName = "letter.docx" 'This is the 07/10 Word Templates name,
Dim NewFileName As String
' Setup directories
cDir = ActiveWorkbook.path + "\" 'Change if appropriate
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
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir + WTempName)
objMMMD.Activate
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir + ThisFileName, _
sqlstatement:="SELECT * FROM `Data$`" ' Set this as required
For r = 2 To lastrow
If Cells(r, 7).Value = "Letter Generated Already" Then GoTo nextrow
'rest of code goes here
Also, instead of checking the Excel file for the Employee name to create the file name, you could do this after you merge the document. For me, this is a little more intuitive to link the file name to the letter you have just merged. To do this update the line further to:
With .DataSource
.FirstRecord = r-1
.LastRecord = r-1
.ActiveRecord = r-1
EmployeeName = .EmployeeName 'Assuming this is the field name
Then immediately before saving the file you can do this:
' Save new file
NewFileName = "Offer Letter - " & EmployeeName & ".docx"
objWord.ActiveDocument.SaveAs cDir + NewFileName
Hope this helps.
The following code works as intended. It saves one .docx and one .pdf file for each entry in the data table while following OpiesDad's recommendations.
Before running, check if the VBA library for Word (Microsoft Word 16.0 Object Library) is activated and make the connection to the Excel data table from the Word template (Mail Merge settings).
Sub MergeMe()
Application.ScreenUpdating = False
Dim bCreatedWordInstance As Boolean
Dim objWord As Word.Application
Dim objMMMD As Word.Document
Dim EmployeeName As String
Dim cDir As String
Dim r As Long
Dim ThisFileName As String
lastrow = Sheets("Dados").Range("A" & Rows.Count).End(xlUp).Row
r = 2
' Setup filenames
Const WTempName = "Proposta.docx" 'Word Template name, Change as req'd
Dim NewFileName As String
On Error Resume Next
' Setup directories
cDir = ActiveWorkbook.Path + "\" 'Change if appropriate
ThisFileName = ThisWorkbook.Name
' 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"
Exit Sub
End If
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir + WTempName)
'loop through each table row
For r = 2 To lastrow
If Cells(r, 7).Value = "Letter Generated Already" Then GoTo nextrow
objMMMD.Activate
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir + ThisFileName, sqlstatement:="SELECT * FROM `Dados$`" ' Set this as required
With objMMMD.MailMerge 'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1
EmployeeName = .DataFields("Nome").Value 'Change "Nome". to the column name for employee names"
End With
.Execute Pause:=False 'executes the mail merge
End With
End With
On Error GoTo 0
' Save new file (.docx & .pdf) and close it
NewFileName = "Offer Letter - " & EmployeeName 'Word Document File Name, Change as req'd"
objWord.ActiveDocument.SaveAs cDir + NewFileName + ".docx"
objWord.ActiveDocument.ExportAsFixedFormat cDir + NewFileName + ".pdf", _
ExportFormat:=wdExportFormatPDF
objWord.ActiveDocument.Close
Cells(r, 7).Value = "Letter Generated Already"
nextrow:
Next r
objMMMD.Close False
objWord.Quit
Application.ScreenUpdating = True
End Sub
Related
I have a Word document containing a few lines of text and a table with many place holders I will fill in from Excel later in the same document but saving it as PDF.
My final goal is to duplicate the whole text in the word file as it is before any modification and paste it every time I have to complete it with the values in the Excel file.
Inside word VBA, this works perfectly. Copy the whole document and past it at the end, duplicating the table and the lines of text.
Selection.WholeStory
Selection.Copy
Selection.MoveDown Unit:=wdParagraph, Count:=2
Selection.PasteAndFormat (wdFormatOriginalFormatting)
And in Excel VBA, I have this working just fine. Except the * Asterics part, I don't know how to execute the code that works in Word VBA from Excel VBA.
Sub GenerateDoc()
DocLoc = Application.ActiveWorkbook.Path & "\CategoryTable2.docx"
'Open Word Template
With Sheet2
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
End If ' Work Running Check
WordApp.Visible = True 'Make the application visible to the user
Set WordDoc = WordApp.Documents.Open(Filename:=DocLoc, ReadOnly:=False) 'Open Template
'This is not workin, no error throw however
'*****************************************
WordDoc.Content.WholeStory
WordDoc.Content.Copy
'***************************************
For component = 15 To 150
iRow = component
If .Cells(iRow, 1).Value = 0 And .Cells(iRow, 2).Text <> "" Then
For CustCol = 3 To 85 'Move Through Columns
If Left(.Cells(13, CustCol).Text, 1) = "[" And Right(.Cells(13, CustCol).Text, 1) = "]" Then
varName = .Cells(13, CustCol).Value 'Determine Variable Name
'varName = "[" & varName & "]"
VarValue = Trim(.Cells(iRow, CustCol).Text) 'Determine Variable Value
With WordDoc.Content.Find
.Text = varName
.Replacement.Text = Application.WorksheetFunction.Text(VarValue, "General")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
End If
Next CustCol
End If
Next component
'This is not working, no error throw however
'**************************************************************************
WordDoc.Content.MoveDown Unit:=wdParagraph, Count:=2
WordDoc.Content.PasteAndFormat (wdFormatOriginalFormatting)
'**************************************************************************
Filename = Application.ActiveWorkbook.Path & "\ComponentsTable.pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
On Error Resume Next
Kill (Filename) 'Delete filename with the same name if it exists
On Error GoTo 0
On Error Resume Next
WordDoc.ExportAsFixedFormat OutputFileName:=Filename, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End With
End Sub
You need to change the logic of your approach.
'WordDoc.Content.WholeStory' specifies an object. Your code does nothing with it. WordDoc.Content.Copy copies an unrelated, other object. Perhaps you mean 'WordDoc.Content.WholeStory.Copy' but this argument is moot. Imagine the entire Word document as one string containing text as well as formatting characters. Therefore you can't copy the WholeStory which is a range. You can only copy its Text.
Once you assign the Text to a string you can paste it to a single cell in Excel. In other words, the String created in Word is understood by Excel and handled within Excel the way Excel handles its own strings. However, that string will definitely contain many characters Excel can't interpret and may contain some that Excel interprets differently. They may even cause Excel to split the original string into more than one cell.
Therefore you need to parse the string lifted from Word and manipulate it into the format you want it to have in Excel. The transition you are asking about takes place at the point where a Word-string becomes an Excel-string. Bear in mind that a Word-range can't become an Excel-range because the two are entirely different animals.
Ok, I found something interesting.
I was not getting any error message because of the
ON ERROR RESUME NEXT
I found that to avoid this, ON ERROR GOTO 0 worked. After that, it was easy to google for errors and find what was wrong. Also, my logic was flawed, I fix it like this. The *Asterix is the interesting part.
Reference https://learn.microsoft.com/en-us/office/vba/api/word.range.copy
Sub GenerateDoc()
Dim WordApp As New Word.Application
Dim WordDoc As Word.Document
DocLoc = Application.ActiveWorkbook.Path & "\CategoryTable2.docx"
'Open Word Template
With Sheet2
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
End If ' Work Running Check
WordApp.Visible = True 'Make the application visible to the user
Set WordDoc = WordApp.Documents.Open(Filename:=DocLoc, ReadOnly:=False) 'Open Template
On Error GoTo 0
'**********************************************************
WordDoc.Range(WordDoc.Content.Start, WordDoc.Content.End).Cut
'
' WordDoc.Content.Selection.WholeStory
' WordDoc.Content.Selection.Copy
For component = 15 To 150
iRow = component
If .Cells(iRow, 1).Value = 0 And .Cells(iRow, 2).Text <> "" Then
'Now past a template copy
'*****************************************************************************************
Set myRange = WordDoc.Range(Start:=WordDoc.Content.End - 1, End:=WordDoc.Content.End - 1)
myRange.Paste
For CustCol = 3 To 85 'Move Through Columns
If Left(.Cells(13, CustCol).Text, 1) = "[" And Right(.Cells(13, CustCol).Text, 1) = "]" Then
varName = .Cells(13, CustCol).Value 'Determine Variable Name
'varName = "[" & varName & "]"
VarValue = Trim(.Cells(iRow, CustCol).Text) 'Determine Variable Value
With WordDoc.Content.Find
.Text = varName
.Replacement.Text = Application.WorksheetFunction.Text(VarValue, "General")
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
End If
Next CustCol
End If
Next component
' WordDoc.MoveDown Unit:=wdParagraph, Count:=2
' WordDoc.PasteAndFormat (wdFormatOriginalFormatting)
Filename = Application.ActiveWorkbook.Path & "\ComponentsTable.pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
On Error Resume Next
Kill (Filename) 'Delete filename with the same name if it exists
On Error GoTo 0
On Error Resume Next
WordDoc.ExportAsFixedFormat OutputFileName:=Filename, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End With
End Sub
First I want to say I am extremely new to utilizing VBA to make my excel sheets more efficient.
I started a few months back and mainly generate code by piecing together what I find online then edit to meet my specific needs.
What Current Code Does:
What I have created allows me to perform a multiple document mailmerge from excel to merge records from my datasoure (Project Information) with the click of a button. Before performing the merge, the user identifies 5 conditions;
Zoning (ex. R20; located in cell C8)
Easement Type (ex. TE; located in cell F8)
The Template to use from the previously uploaded template list (located in cell J8)
The Area of the Lot (located in cell P8)
If it is a just compensation Report ("yes" or "no" located in cell C11)
The criteria above identifies the record numbers that match the specified criteria to create individual mailmerge documents for each record and saves in the corresponding property file which is associated with the record number. The sheet that is generating mailmerge ("report Creation") is different from the datasource and maintains records of when the mailmerge was performed and what template was used. This sheet also contains the list of records and is the search range for the criteria (record start on line 39 so +37 is used to match "Report Creation" row).The code also contains a loading bar that appears when the merging is being performed and shows percentage complete (percentage is not correct but used more to show user merge is in progress).
My Question:
What I am now trying to adjust is when the mailmerge is performed I still want the individual documents but I want to maintain the link between the new document and the datasource. That way I can always update the word document if any changes occur. It currently merges to a word document that no longer contains any mailmerge field and is as if I finalized a merge.
I am assuming this is a minor change after the .opendatasource but cant pinpoint what to change.
My Code may be a bit messy and could definitely use some cleanup but it gets the job done. See below.
Current Code:
Sub RunMerge()
Dim StrMMSrc As String, StrMMDoc As String, StrMMDocName As String, StrName As String, dataname As String
Dim i As Long
Dim Load As Integer
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim ReportNum, AddressName, SaveLoc, NewFile, fpath, subfldr, DateCr As String
Dim ExpTemp, ExTempDate, ExpReview, ExpRevDate As Range
Dim ExpRow, CustCol, lastRow, StrMMDocRow, ExportedDoc, LotSizeSM, LotSizeLG, ActualLS, symbpos As Long
Dim FileName, Zoning, Ease, LotSizeRNG, Ztype, Etype As String
On Error GoTo errhandler
'Turn off at the start
TurnOffFunctionality
wdApp.DisplayAlerts = wdAlertsNone
Set wsreports = ThisWorkbook.Worksheets("Report Creation")
Set wsinfo = ThisWorkbook.Worksheets("Project Information")
Set wsdetails = ThisWorkbook.Worksheets("Project Details")
StrMMSrc = ThisWorkbook.fullname
lastRow = wsinfo.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).row
dataname = wsinfo.Name
'set folder path for saving documents
fpath = ThisWorkbook.Sheets("Project Details").Range("E30").Value
subfldr = wsdetails.Range("F34").Value
'date exported
DateCr = Format(Date, "mm-dd-yyyy")
ExportedDoc = 0
With wsreports
' set range criteria
LotSizeRNG = .Range("P8").Value
symbpos = InStr(1, LotSizeRNG, "<>")
LotSizeSM = CInt(Left(LotSizeRNG, symbpos - 1))
LotSizeLG = CInt(Mid(LotSizeRNG, symbpos + 2))
If LotSizeLG = "" Then LotSizeLG = 100000000
If wsreports.Range("J8").Value = Empty Then
MsgBox "Please Select A Template From The Dropdown List to Export"
wsreports.Range("J8").Select
GoTo errhandler
End If
StrMMDocRow = .Application.Match(Range("J8").Value, .Range("C1:C34"), 0) 'Set Template Row
StrMMDocName = .Range("J8").Value 'set template name
Zoning = .Range("C8").Value 'set Zoning Criteria
Ease = .Range("F8").Value 'Set Easement Criteria
StrMMDoc = .Range("AB" & StrMMDocRow).Value 'Word Document Filename
End With
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Open(FileName:=StrMMDoc, AddToRecentFiles:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, AddToRecentFiles:=False, LinkToSource:=False,
ConfirmConversions:=False, _
ReadOnly:=True, Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"User ID=Admin;Data Source=" & StrMMSrc & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";", _
SQLStatement:="SELECT * FROM `Project Information$`", SQLStatement1:="", SubType:=wdMergeSubTypeAccess
UserFormLoad.Show
For i = 2 To lastRow
Ztype = wsreports.Range("D" & i + 37).Value
Etype = wsreports.Range("F" & i + 37).Value
ActualLS = wsreports.Range("E" & i + 37).Value
'Check the row for matching zone and easement cristeria
If wsreports.Range("C11").Value = "No" And StrMMDocName <> wsreports.Range("H" & i + 37).Value _
And Ztype = Zoning And ActualLS >= LotSizeSM And ActualLS <= LotSizeLG And Etype = Ease Then
ExportedDoc = ExportedDoc + 1
'set newfile location
ReportNum = wsreports.Range("B" & i + 37).Value
AddressName = wsreports.Range("C" & i + 37).Value
SaveLoc = fpath & "\#" & ReportNum & "_" & AddressName & "\" & subfldr
'generate new file name with date
NewFile = SaveLoc & "\" & AddressName & "_Draft Report_" & DateCr & ".docx"
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i - 1
.LastRecord = i - 1
.ActiveRecord = i - 1
StrName = NewFile
End With
.Execute Pause:=False
wsreports.Range("I" & i + 37).Value = StrMMDocName
wsreports.Range("L" & i + 37).Value = DateCr
With wdApp.ActiveDocument
.SaveAs FileName:=StrName, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close savechanges:=False
End With
Dim r As Integer
r = i
Load = Application.WorksheetFunction.RoundDown((r + 1) / (lastRow) * 100, 0)
DoEvents
UserFormLoad.LoadBar.Width = Load / 100 * 222
UserFormLoad.LabelProg.Caption = Load & "%"
End If
Next i
Unload UserFormLoad
.MainDocumentType = wdNotAMergeDocument
End With
.Close savechanges:=False
End With
If ExportedDoc = 0 Then
MsgBox "No Properties Matched The Criteria Specified. Use The Table To Verify The Easement and Zoning Have Properties Meeting Criteria.", vbOKOnly, "No Matches Found"
Else
MsgBox "The Property Draft Reports Were Exported Successfully. Please Check Project Property" & subfldr & " Folder for Word Document.", vbOKOnly, "Export Successfull"
End If
'cleanup if error
errhandler:
TurnOnFunctionality
wdApp.DisplayAlerts = wdAlertsAll
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
You cannot use mailmerge for what you want to achieve. You would need to use LINK fields instead of MERGEFIELDs and update the LINK field row references for each output document.
An alternative approach would be to re-run the mailmerge for just the record(s) you want to update.
Good Morning
I'm trying to clean up a macro that is behaving erraticly. It used to work - on a good day. But it throws up this error: "Microsoft Excel is waiting for another application to complete an OLE action". I've tried to clean it up (which caused all sorts of other errors, now sorted) and I'm back to being able to step through it but it again stops at above error.
What I have noticed that it used to do one certificate and then throw the error but now the error occurs straight away when it's trying to open the template. This is the line:
Set objMMMD = objWord.Documents.Open(cDir & WTempName)
objMMMD.Activate
My original thought was that the code didn't close Word cleanly but now that the error is so early, that can't be it. I don't have Word open. - Since it used to open Word before my revision, the code should be correct as well.
I can't find much on the error apart from that it seems to occur in more complicate codes due to timeout and how to suppress the message. Neither seems to be of help here.
Below the entire code. Does anybody have any idea why Excel can't open Word to do the mailmerge?
Public Sub MailMergeCert()
Dim bCreatedWordInstance As Boolean
Dim objWord As Word.Application
Dim objMMMD As Word.Document
Dim FirstName As String
Dim LastName As String
Dim Training As String
Dim SeminarDate As String
Dim HoursComp As String
Dim Location As String
Dim Objectives As String
Dim Trainer As String
Dim cDir As String
Dim ThisFileName As String
'Your Sheet names need to be correct in here
Dim sh1 As Worksheet
Set sh1 = ActiveWorkbook.Sheets("Ultrasound")
Dim r As Long
r = 2
FirstName = sh1.Cells(r, 1).Value
LastName = sh1.Cells(r, 2).Value
Training = sh1.Cells(r, 3).Value
SeminarDate = Format(sh1.Cells(r, 4).Value, "d mmmm YYYY")
HoursComp = sh1.Cells(r, 5).Value
Location = sh1.Cells(r, 6).Value
Objectives = sh1.Cells(r, 7).Value
Trainer = sh1.Cells(r, 8).Value
'Setup filenames
Const WTempName = "Certificate_Ultrasound_2017.docx" 'Template name
'Data Source Location
cDir = ActiveWorkbook.Path + "\" 'Change if required
ThisFileName = ThisWorkbook.Name
On Error Resume Next
'Create Word instance
bCreatedWordInstance = False
Set objWord = CreateObject("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
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir & WTempName)
objMMMD.Activate
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir & ThisFileName, _
sqlstatement:="SELECT * FROM `Ultrasound$`" ' Set this as required
lastrow = Sheets("Ultrasound").Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To lastrow
If IsEmpty(Cells(r, 11).Value) = False Then GoTo nextrow
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
'Save new file PDF
Dim UltrasoundCertPath As String
UltrasoundCertPath = "C:\Users\305015724\Documents\ApplicationsTraining\2016\Ultrasound\"
Dim YYMM As String
YYMM = Format(sh1.Cells(r, 16).Value, "YYMM")
Dim NewFileNamePDF As String
NewFileNamePDF = YYMM & "_" & sh1.Cells(r, 3).Value & "_" & sh1.Cells(r, 7).Value '& ".pdf" 'Change File Name as req'd"
objWord.ActiveDocument.ExportAsFixedFormat UltrasoundCertPath & NewFileNamePDF, ExportFormat:=wdExportFormatPDF
nextrow:
Next r
End With
' Close the Mail Merge Main Document
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
If bCreatedWordInstance Then
objWord.Quit
End If
Set objWord = Nothing
Cells(r, 11).Value = Date
0:
Set objWord = Nothing
End Sub
Try changing
cDir = ActiveWorkbook.Path + "\"
To
cDir = ActiveWorkbook.Path & "\"
Does that make a difference. Also try printing the cDir if its what expect.
Try message box the cDir to check the path.
MsgBox(cDir, vbOKOnly, "Testing cDir")
Good Morning
I have modified the code from this post: Automating Mail Merge using Excel VBA
But I only want pdf output but as soon as I take out the word code, it baulks. I think the problem is that if I don't save it as word, it doesn't shut the template down properly (there is code to close it). I have to manually click "Don't Save" and then it chokes as it tries to reopen the file for the next line. Any idea how to get around that? - Any help much appreciated. Thanks.
Public Sub MailMergeCert()
Dim bCreatedWordInstance As Boolean
Dim objWord As Word.Application
Dim objMMMD As Word.Document
Dim FirstName As String
Dim LastName As String
Dim Training As String
Dim SeminarDate As String
Dim HoursComp As String
Dim Location As String
Dim Objectives As String
Dim Trainer As String
Dim r As Long
Dim ThisFileName As String
'Your Sheet names need to be correct in here
Set sh1 = Sheets("Periop")
lastrow = Sheets("Periop").Range("A" & Rows.Count).End(xlUp).Row
r = 2
For r = 2 To lastrow
If IsEmpty(Cells(r, 10).Value) = False Then GoTo nextrow
FirstName = sh1.Cells(r, 1).Value
LastName = sh1.Cells(r, 2).Value
Training = sh1.Cells(r, 3).Value
SeminarDate = sh1.Cells(r, 4).Value
HoursComp = sh1.Cells(r, 5).Value
Location = sh1.Cells(r, 6).Value
Objectives = sh1.Cells(r, 7).Value
Trainer = sh1.Cells(r, 8).Value
SeminarDate = Format(sh1.Cells(r, 4).Value, "d mmmm YYYY")
' Setup filenames
Const WTempName = "Certificate_Periop_2016.docx" 'Template name
' 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
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir + WTempName)
objMMMD.Activate
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir + ThisFileName, sqlstatement:="SELECT * FROM `Periop$`" ' Set this as required
With objMMMD.MailMerge 'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1
' EmployeeName = .EmployeeName
End With
.Execute Pause:=False
End With
End With
' Save new file
'Path and YYMM
Dim PeriopCertPath As String
PeriopCertPath = "C:\Users\305015724\Documents\ApplicationsTraining\2016\Periop\"
Dim YYMM As String
YYMM = Format(sh1.Cells(r, 11).Value, "YYMM")
'Word document
Dim NewFileNameWd As String
NewFileNameWd = YYMM & "_" & sh1.Cells(r, 12).Value & "_" & sh1.Cells(r, 2).Value & ".docx" 'Change File Name as req'd"
objWord.ActiveDocument.SaveAs Filename:=PeriopCertPath & NewFileNameWd
'PDF
Dim NewFileNamePDF As String
NewFileNamePDF = YYMM & "_" & sh1.Cells(r, 12).Value & "_" & sh1.Cells(r, 2).Value '& ".pdf" 'Change File Name as req'd"
objWord.ActiveDocument.ExportAsFixedFormat PeriopCertPath & NewFileNamePDF, ExportFormat:=wdExportFormatPDF
' 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
I recorded saving a workbook as a pdf and this is the output:
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
"C:\Users\me\Desktop\Doc1.pdf", 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
It seems like you might try:
objWord.ActiveDocument.ExportAsFixedFormat PeriopCertPath & NewFileNamePDF,
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False
The pdf generation always worked and I think I now have the Word bit sorted as well. This is the part of the code that generates the pdf and then closes Word (and a few other things ...)
'Print Certificate
'Print required
If sh1.Cells(r, 12) = "print" Then
'remove background image
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.WholeStory
Selection.Cut
'Print Certificate
objWord.ActiveDocument.PrintOut
'Close the Mail Merge Main Document
objWord.ActiveDocument.Close (wdDoNotSaveChanges)
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
Else
'Close the Mail Merge Main Document
objWord.ActiveDocument.Close (wdDoNotSaveChanges)
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
End If
' Create a Word Application instance
bCreatedWordInstance = False
Set objWord = GetObject(, "Word.Application")
' Close the New Mail Merged Document
If bCreatedWordInstance Then
objWord.Quit
End If
0:
Set objWord = Nothing
I am trying to generate certificates using the records from my Excel master data file. My coding throws me a VBA error "Runtime error - 5631; Word could not merge the main document with the data source because the data records were empty or no data records matched your query options" every alternate time.
For some data, the code works, whereas for most of the time, it throws error 5631 in the line .Execute Pause:=False
There are records inside the file, so I know there is something wrong with my Query itself.
Other info:
Temp1 = Cookies mailmerge word template,
Temp2 = Chocolates mailmerge word template,
Temp3 = Drinks mailmerge word template
Sheet1 = Cookies sales excel data,
Sheet2 = Chocolates sales excel data,
Sheet3 = Drinks sales excel data
My complete code:
Sub Generate_Cert()
Dim wd As Object
Dim wdoc As Object
Dim i As Integer
Dim isInvalid As Boolean
Dim statement, fileSuffix, datasource As String
Dim aSheet As Worksheet
Dim cDir As String
Dim wdName As String
Const wdFormLetters = 0
Const wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0
Const wdDefaultFirstRecord = 1
Const wdDefaultLastRecord = -16
SalesDate = Format(Worksheets("SalesMaster").Cells(2, "B").Value, "DDMMYYYY")
On Error Resume Next
'Check Word is open or not
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
'If Not open, open Word Application
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
'Getting datasource
datasource = ThisWorkbook.Path & "\" & ThisWorkbook.Name
'Looping all sheet from workbook
For Each aSheet In ThisWorkbook.Sheets
'If the first cell is not empty
If aSheet.Range("A2").Value <> "" Then
isInvalid = False
'Check sheet for SQLStatement and save file name.
Select Case aSheet.Name
Case "Sheet1"
statement = "SELECT * FROM `Sheet1$`"
fileSuffix = " Cookies Sales"
i = 1
Case "Sheet2"
statement = "SELECT * FROM `Sheet2$`"
fileSuffix = " Chocolates Sales"
i = 2
Case "Sheet3"
statement = "SELECT * FROM `Sheet3$`"
fileSuffix = " Drinks Sales"
i = 3
Case Else
isInvalid = True
End Select
'If sheet should save as word
If Not isInvalid Then
'Getting new word document
Set wdoc = wd.Documents.Open("C:\Desktop\Sales Certs\Temp" & i & ".docx")
With wdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=datasource, AddToRecentFiles:=False, _
Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & datasource & ";Mode=Read", _
SQLStatement:=statement
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .datasource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'wdoc.Visible = True
wdName = SalesDate & fileSuffix & ".docx"
cDir = ActiveWorkbook.Path + "\"
wd.ActiveDocument.SaveAs cDir + wdName
MsgBox SalesDate & fileSuffix & " has been generated and saved"
'wdoc.SaveAs Filename:=wdoc.Name
wdoc.Close SaveChanges:=True
End If
End If
Next aSheet
wd.Quit SaveChanges:=wdDoNotSaveChanges
End Sub
This error was occurring because my source excel document was not saved before the Mailmerge execution. No need to save the word document, as there was no pre-processing necessary before the Mailmerge execution.
So I basically declared wBook as workbook & added this : wBook.Save
Sub Generate_Cert()
Dim wd As Object
Dim wdoc As Object
Dim i As Integer
Dim isInvalid As Boolean
Dim statement, fileSuffix, datasource As String
Dim wBook As Workbook
Dim aSheet As Worksheet
Dim cDir As String
Dim wdName As String
Const wdFormLetters = 0
Const wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0
Const wdDefaultFirstRecord = 1
Const wdDefaultLastRecord = -16
wBook.save '<~~~~~~~ SAVE BEFORE MAILMERGE STARTS
SalesDate = Format(Worksheets("SalesMaster").Cells(2, "B").Value, "DDMMYYYY")
On Error Resume Next
'Check Word is open or not
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
'If Not open, open Word Application
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
'Getting datasource
datasource = ThisWorkbook.Path & "\" & ThisWorkbook.Name
'Looping all sheet from workbook
For Each aSheet In ThisWorkbook.Sheets
'If the first cell is not empty
If aSheet.Range("A2").Value <> "" Then
isInvalid = False
'Check sheet for SQLStatement and save file name.
Select Case aSheet.Name
Case "Sheet1"
statement = "SELECT * FROM `Sheet1$`"
fileSuffix = " Cookies Sales"
i = 1
Case "Sheet2"
statement = "SELECT * FROM `Sheet2$`"
fileSuffix = " Chocolates Sales"
i = 2
Case "Sheet3"
statement = "SELECT * FROM `Sheet3$`"
fileSuffix = " Drinks Sales"
i = 3
Case Else
isInvalid = True
End Select
'If sheet should save as word
If Not isInvalid Then
'Getting new word document
Set wdoc = wd.Documents.Open("C:\Desktop\Sales Certs\Temp" & i & ".docx")
With wdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=datasource, AddToRecentFiles:=False, _
Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & datasource & ";Mode=Read", _
SQLStatement:=statement
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .datasource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'wdoc.Visible = True
wdName = SalesDate & fileSuffix & ".docx"
cDir = ActiveWorkbook.Path + "\"
wd.ActiveDocument.SaveAs cDir + wdName
MsgBox SalesDate & fileSuffix & " has been generated and saved"
'wdoc.SaveAs Filename:=wdoc.Name
wdoc.Close SaveChanges:=True
End If
End If
Next aSheet
wd.Quit SaveChanges:=wdDoNotSaveChanges
End Sub