Excel VBA mail merge with conditions - excel

I am really looking forward to get some help because I am trying for so long now...
I want to get a button in excel that starts a word mailmerge and save every letter as a single document. I already found a code, that is doing this fine.
Now comes the problem: I need excel to take different word templates depending on the number in column A (Column A is called Anz). So if column A = 0 there wont be any mail merge (I already managed this by adding "where (Anz>0) to the sql statement.
If column A = 1 excel shall take sb1.docx as the proper mail merge template.
If column A = 2 it shall take sb2.docx and so on.
The numbers go from 0 to 6.
I have no idea how to to this :(
My code so far (that is working but only for the sb1.docx).
Sub RunMerge()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*/\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "sb1.docx"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Sheet1$` where (Anz>0)"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("ID")) = "" Then Exit For
StrName = .DataFields("ID")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With wdApp.ActiveDocument
.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub

Try this.
Requirements:
- Each Anz number has it's corresponding template
- The excel spreadsheet has a column called "Anz"
- You have to add the Microsoft Word object library to VBA IDE references
Implementation:
1) Copy and paste the code inside a vba module
2) Customize the code (seek for >>>> customize this <<<<)
Updates:
1) Adjusted the queryString
2) Updated the OpenDataSource code to be more clear
3) Added a fileCounter
Code:
' First you have to configure the settings in each template so the word template filters the data already
' Also add a reference in Excel / VBA IDE to: Microsoft Word [Version] Object Library
Public Sub RunMergeDifferentWordTemplates()
' Declare objects
Dim wordApp As Word.Application
Dim wordTemplate As Word.Document
Dim wordMergedDoc As Word.MailMerge
' Declare other variables
Dim sourceBookPath As String
Dim sheetSourceName As String
Dim excelColumnFilter As String
Dim queryString As String
Dim baseQueryString As String
Dim wordTemplateDirectory As String
Dim wordTemplateFileName As String
Dim wordTemplateFullPath As String
Dim wordOutputDirectory As String
Dim wordOutputFileName As String
Dim wordOutputFullPath As String
Dim idListValues As Variant ' Array
Dim idValue As Integer
Dim idCounter As Integer
Dim recordCounter As Integer
Dim fileCounter As Integer
' >>>>> Customize this <<<<<<
' This would be better to hold it in an Excel structured table
' I'm not including 0 as it's not needed (these would correspon to the anz values).
idListValues = Array(1, 2, 3, 4, 5, 6)
' Excel source settings:
sourceBookPath = ThisWorkbook.FullName
sheetSourceName = "Sheet1" ' The sheet where the data of the mail merge is located
excelColumnFilter = "Anz" ' The column we use to filter the mail merge data
baseQueryString = "SELECT * FROM `" & sheetSourceName & "$` where `" & excelColumnFilter & "` = [columFilterValue] order by `" & excelColumnFilter & "` ASC" ' Would be a better practice to use an Excel structured table: https://support.office.com/en-us/article/overview-of-excel-tables-7ab0bb7d-3a9e-4b56-a3c9-6c94334e492c
' Word settings:
wordTemplateDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
wordTemplateFileName = "sb[columFilterValue].docx" ' Include in the string [columFilterValue] where you want it to be replaced (remember that you have one template for each number)
wordOutputDirectory = ThisWorkbook.Path & "\" ' Include slash at the end
wordOutputFileName = "MailMergeDifferent[columFilterValue]_[Record]" ' Leave the [columFilterValue] and [Record] tags inside the path to identify each document. We'll replace it ahead, dynamically
' Initialize word object
Set wordApp = New Word.Application
wordApp.Visible = True
wordApp.DisplayAlerts = wdAlertsNone
' Loop through each idValue in idListValues
For idCounter = 0 To UBound(idListValues)
' Process each word template
idValue = idListValues(idCounter)
queryString = Replace(baseQueryString, "[columFilterValue]", idValue)
wordTemplateFullPath = wordTemplateDirectory & Replace(wordTemplateFileName, "[columFilterValue]", idValue)
Set wordTemplate = wordApp.Documents.Open(wordTemplateFullPath)
Set wordMergedDoc = wordTemplate.MailMerge
' Process the template's mail merge
With wordMergedDoc
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=sourceBookPath, _
ReadOnly:=True, _
Format:=wdOpenFormatAuto, _
Revert:=False, _
AddToRecentFiles:=False, _
LinkToSource:=False, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=" & sourceBookPath & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=queryString
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
' Each anz have matching records inside the excel worksheet (generate a word file for each one)
For recordCounter = 1 To .DataSource.RecordCount
' Select each record
With .DataSource
.FirstRecord = wordMergedDoc.DataSource.ActiveRecord
.LastRecord = wordMergedDoc.DataSource.ActiveRecord
End With
.Execute Pause:=False
' Add the columnFilterValue and the record identifier to the word file name
' Replace the columnFilterValue and the Record tags
wordOutputFullPath = wordOutputDirectory & Replace(Replace(wordOutputFileName, "[columFilterValue]", idValue), "[Record]", recordCounter)
' Save and close the resulting document
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputFullPath, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
wordApp.ActiveDocument.Close SaveChanges:=False
.DataSource.ActiveRecord = wdNextRecord
' Count files generated
fileCounter = fileCounter + 1
Next recordCounter
End With
' Close word template without saving
wordTemplate.Close False
Next idCounter
' Clean up word objects
wordApp.Visible = False
Set wordApp = Nothing
' Alert process finished
MsgBox fileCounter & " files generated"
End Sub

Related

How to mail merge last row only

I have a couple of excels I am messing around with practicing VBA. They all at have code to mail merge. On one excel I subtract the row number from the row where my headers are. For example my headers are on row 22 and my data starts at row 23. So I subtract 22 from the row number and it begins the mail merge from there (or it only starts to count records from there. I am unsure). So if I have 3 rows of data that would be row 23 to 25. The code subtracts 22 and I am left with 3 records to mail merge. I am learning VBA so I have a hard time figuring out the code I need to only do the last row. Here is my mail merge code:
Private intakeForm As String
Private wdApp As Word.Application
Public newFilePath As String
Public newFolderName As String
Sub MailMergeAutomation()
Dim filePath As String
filePath = ThisWorkbook.Path & "\" & "Forms" & "\"
Dim wdDoc As Word.Document
Dim TargetDoc As Word.Document
Dim recordNumber As Long
Dim selRow As Range
Set selRow = Selection
intakeForm = "New Intake Form"
recordNumber = selRow.Row
Set fso = New Scripting.FileSystemObject
Set wdApp = New Word.Application
If wdApp Is Nothing Then
Set wdApp = New Word.Application
End If
Set fso = New FileSystemObject
With wdApp
.Visible = False
Set wdDoc = .Documents.Open(filePath & intakeForm)
wdDoc.MailMerge.MainDocumentType = wdFormLetters
wdDoc.MailMerge.OpenDataSource _
Name:=ThisWorkbook.Path & "\" & ThisWorkbook.Name, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";Mode=Read", _
SQLStatement:="SELECT * FROM [Headers]"
With wdDoc.MailMerge
.Destination = wdSendToNewDocument
With .DataSource
.FirstRecord = recordNumber - 22
.LastRecord = recordNumber - 22
'.ActiveRecord = .Ac
.LastRecord = recordNumber - 22
End With
.Execute Pause:=False
wdApp.Visible = False
Set TargetDoc = wdApp.ActiveDocument
TargetDoc.SaveAs2 Filename:=ThisWorkbook.Path & "\" & Sheet1.Cells(recordNumber, 3) & " " & "- intakeForm.docx"
wdDoc.Close SaveChanges:=False
End With
End With
Set wdDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
End Sub
The easiest and simplest way to get the last row is usually something like sht.Cells(sht.Rows.Count, "A").End(xlUp).Row and should help you. There are a few other ways of doing it too, so for the record - 5 Different Ways to Find The Last Row or Last Column Using VBA

MailMerge: From Excel to Word Saving Individual Documents for Each Record While Maintaining Link to Source

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.

A macro that calls 2 macros depending on the cell value

I have this chunk of code :
The macro that calls 2 other macros depending on the cell value is this :
Option Explicit
Function lastRow(col As Variant, Optional wks As Worksheet) As Long
If wks Is Nothing Then
Set wks = ActiveSheet
End If
lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row
End Function
Sub runMacros()
Dim vDat As Variant
Dim i As Long
Dim wks As Worksheet
Set wks = ActiveSheet
With wks
vDat = .Range(.Cells(1, "G"), .Cells(lastRow("G"), "G"))
End With
For i = LBound(vDat) To UBound(vDat)
If vDat(i, 1) = "First" Then
Macro3
Macro1
ElseIf vDat(i, 1) = "Second" Then
Macro3
Macro2
End If
Next i
End Sub
The first macro that is being called is this(Macro3) - it just creates a new folder if it does not exist:
Sub Macro3()
Dim Path As String
Dim Folder As String
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
End If
End Sub
and then I have this macro:
Sub Macro1()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, SavePath As String, StrFileName As String, MailSubjectName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
SavePath = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" 'Name of the folder
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "RejectionLetterEmployee.docx" 'Name of the word file
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Rejection$`"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Name") 'File name will be determined by this column name
MailSubjectName = .DataFields("ID")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
StrFileName = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\" & StrName
With wdApp.ActiveDocument
'.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False 'Save as WORD file(not needed at the moment)
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder where the excel sheet exists(not needed)
.SaveAs Filename:=SavePath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False 'Save to the folder that has been created by Path_Exists function
.Close SaveChanges:=False
' Set OutApp = CreateObject("Outlook.Application")
' Set OutMail = OutApp.CreateItem(0)
' On Error Resume Next
' With OutMail
' .To = ""
' .SentOnBehalfOfName = ""
' .CC = ""
' .BCC = ""
' .Subject = "ID" & " " & MailSubjectName & " " & StrName
' .BoDy = ""
' .Attachments.Add StrFileName & ".pdf"
' .Display
'.Send
' End With
' On Error GoTo 0
' Set OutMail = Nothing
' Set OutApp = Nothing
End With
' Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub
Macro1 and Macro2 are the same code but they use a different Word file to create the PDF - Macro1 runs if a cell in "G" column contains the string "first" and Macro2 runs if it contains "second".
The macros create a PDF file and sends it via Outlook.
The problem with Macro1 and Macro2 is that they have a For loop which runs through all rows which basically contradicts what I want to do based on a cell value.
I tried to tweak it a little but since im not familiar that much with VBA I couldnt make it run on the row based on the For loop that runMacros() executes when it calls the 2 other macros.
I only succeeded making it work only on the first row or the last row.
So my question is this : How would I fix Macro1 code to work on a row that runMacros() check.
For example : runMacros() is executed via button.
it checks if G2 cell contains either "first" or "second".
if it contains "first" it will run Macro3 and Macro1.
if it contains "second" it will run Macro3 and Macro2.
runMacros() will then go to the next row, check and execute the macros until it reaches an empty row.
currently Macro1 and Macro2 have a for loop which is wrong because if the G2 contains "first" and G3 contains "second" all the PDF files will be according to Macro2 because it just replaced what Macro1 did
I want Macro1 and Macro2 to follow the row that runMacros() is checking and only execute on that row.
How do I do that?
In answering your question in passing parameters, there are a couple ways to do this. In the first example, create your vDat variable as a Range, then loop over the range and pass a range parameter.
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Range
With wks
Set vDat = .Range("G1").Resize(lastRow("G"), 1)
End With
Dim i As Long
For i = 1 To vDat.Rows.Count
If vDat.Offset(i, 0).Value = "First" Then
Macro3 vDat.Rows(i)
Macro1 vDat.Rows(i)
ElseIf vDat.Offset(i, 0).Value = "Second" Then
Macro3 vDat.Rows(i)
Macro2 vDat.Rows(i)
End If
Next i
End Sub
Private Sub Macro1(ByRef theRow As Range)
Debug.Print "Macro1 row address = " & theRow.Address
End Sub
Private Sub Macro2(ByRef theRow As Range)
Debug.Print "Macro2 row address = " & theRow.Address
End Sub
Private Sub Macro3(ByRef theRow As Range)
Debug.Print "Macro3 row address = " & theRow.Address
End Sub
But you actually created vDat as an array, so you can just pass the value of that row in the array:
Sub runMacros()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim vDat As Variant
With wks
vDat = .Range("G1").Resize(lastRow("G"), 1).Value
End With
Dim i As Long
For i = LBound(vDat, 1) To UBound(vDat, 1)
If vDat(i, 0) = "First" Then
Macro3 vDat(i, 0)
Macro1 vDat(i, 0)
ElseIf vDat(i, 0) = "Second" Then
Macro3 vDat(i, 0)
Macro2 vDat(i, 0)
End If
Next i
End Sub
Private Sub Macro1(ByVal theRowValue As Variant)
Debug.Print "Macro1 row value = " & theRowValue
End Sub
Private Sub Macro2(ByVal theRowValue As Variant)
Debug.Print "Macro2 row value = " & theRowValue
End Sub
Private Sub Macro3(ByVal theRowValue As Variant)
Debug.Print "Macro3 row value = " & theRowValue
End Sub
What is not clear in your code and question is how the row relates to the DataSource or how you are using it in Macro1 or Macro2. I would also suggest renaming your macros to something more descriptive to what action the macro is performing.
With MailMerge you can create a batch of documents from a datasource.
Using the Status column as a WHERE clause in the datasource SQL allows you to create the
documents with only 2 runs of the same subroutine using a parameter to apply the different template.
Option Explicit
Sub runMacros()
Dim Template1 As String, Template2 As String, Path As String, Folder As String
Template1 = ThisWorkbook.Path & "RejectionLetterEmployee.docx"
Template2 = ThisWorkbook.Path & "RejectionLetterEntrepreneur.docx"
' create path for documents
Path = "C:\Users\" & Environ("Username") & "\Desktop\Rejection Folder\"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
MkDir Path
End If
' create documents
CreateDocuments "First", Template1, Path
CreateDocuments "Second", Template2, Path
MsgBox "Ended"
End sub
Sub CreateDocuments(Status As String, Template As String, SavePath)
MsgBox "Running macro for Status = [" & Status & "] using " & Template & vbCrLf & _
" into Folder " & SavePath, vbInformation
Const StrNoChr As String = """*./\:?|"
' Paths and Filename
Dim strMMSrc As String, strMMDoc As String, strMMPath As String
Dim StrFileName As String, t0 As Single
t0 = Timer
' open template
Dim wdApp As New Word.Application, wdDoc As Word.Document, i As Integer, j As Integer
Dim strName, MailSubjectName
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
Set wdDoc = wdApp.Documents.Open( _
Filename:=Template, _
AddToRecentFiles:=False, _
ReadOnly:=True, _
Visible:=False)
strMMSrc = ThisWorkbook.FullName ' datasource name
With wdDoc.MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.OpenDataSource Name:=strMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=strMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=" SELECT * FROM `Rejection$` WHERE Status = '" & Status & "'"
' confirm to create docs
If vbNo = MsgBox(.DataSource.RecordCount & " documents will be created in " & SavePath & _
", continue ?", vbYesNo, "Confirm") Then
GoTo skip
End If
' create one doc for each record in datasource
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
strName = Trim(.DataFields("Name"))
MailSubjectName = Trim(.DataFields("ID"))
'Debug.Print "Raw", i, strName, MailSubjectName
If strName = "" Then Exit For
End With
' do merge
.Execute Pause:=False
' construct doc filename to save
' replace illegal characters
For j = 1 To Len(StrNoChr)
strName = Replace(strName, Mid(StrNoChr, j, 1), "_")
MailSubjectName = Replace(MailSubjectName, Mid(StrNoChr, j, 1), "_")
Next
Debug.Print "Cleaned ", i, strName, MailSubjectName
'Save to the folder that has been created by Path_Exists function
StrFileName = SavePath & strName
With wdApp.ActiveDocument
.SaveAs Filename:=SavePath & strName & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
MsgBox i - 1 & " documents created in " & SavePath, vbInformation, "Completed in " & Int(Timer - t0) & " secs"
skip:
' cleanup
wdDoc.Close SaveChanges:=False
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub

Save Excel mailmerge to PDF only on the last row with data

I have been using a code which uses mailmerge from the excel sheet to my word template and then proceeds to save all the rows in my excel sheet to PDF(in the word template of course). - The code works perfectly fine.
The code was taken from this forum :
https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
How my Excel sheet looks like :
A1-E1 = Headers
A2-E2 = data
A3-E3 = data
A4-E4 = data
and so on...
How the code currently works :
The code saves all rows of data from the excel sheet into my word template(with mailmerge) and then into PDFs.
My goal :
I want to change the code so it only saves the last row of data in the excel sheet into my word template(with mailmerge) and then into to PDF.
Sub RunMerge()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
' Note: this code requires a reference to the Word object model to be set, via Tools|References in the VBE.
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
wdApp.DisplayAlerts = wdAlertsNone
StrMMSrc = ThisWorkbook.FullName
StrMMPath = ThisWorkbook.Path & "\"
StrMMDoc = StrMMPath & "MailMergeDocument.doc"
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Sheet1$`"
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Name")) = "" Then Exit For
StrName = .DataFields("Name")
End With
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With wdApp.ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
'.SaveAs Filename:=StrMMPath & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
.MainDocumentType = wdNotAMergeDocument
End With
.Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub
Thanks in advance.
Replace:
For i = 1 To .DataSource.RecordCount
with:
i = .DataSource.RecordCount
or, if there are rows in use below that in other columns:
i = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row - 1
where 'A' is any column not containing data below the last record and delete both:
If Trim(.DataFields("Name")) = "" Then Exit For
and:
Next i

Runtime error 5631

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

Resources