VBA/Macro help needed for Mail Merge in Excel and export each record as PDF format

Folks,

I have below macro to do mail merge in Excel, it does create new workbook for each record and save as separate workbooks, and file names as current date and time. What I need is the macro to create the new workbook or sheets and save as PDF format and the file name should be Mail Merge "Field 2 + Field 1 + Field 5". My sample files (attached) will explain better.

Option Explicit


' array list of fields to merge
Dim strMergeFields() As String
' range where merge data comes from
Dim rngSourceRange As Excel.Range

' path to workbook containing template
Dim strTemplatePath As String
' name of merge sheet on template
Dim strSheetName As String
' track user cancellation
Dim cancelled As Boolean

Private Sub initGlobals()
  Dim rngTemp As Excel.Range
  Dim wkbTemp As Excel.Workbook

  Dim iSize As Long
  Dim iCount As Long
  
  ' get source range
  On Error Resume Next
  Set rngSourceRange = Application.InputBox( _
    Prompt:="Select source data range. Include headers.", _
    Title:="Merge: Select Source Data", _
    Type:=8)
  On Error GoTo 0
  
  If rngSourceRange Is Nothing Then
    cancelled = True
    Exit Sub
  End If
  
  If (rngSourceRange.Rows.Count < 2) Then
    cancelled = True
    Call MsgBox("You must select a range with at least two rows.", _
              vbOKOnly + vbExclamation, "Merge: Error")
    Exit Sub
  End If
  
  ' resize array as needed
  iSize = rngSourceRange.Columns.Count
  ReDim strMergeFields(1 To iSize)
  
  ' get template file name
  With Application.FileDialog(Office.MsoFileDialogType.msoFileDialogFilePicker)
    .AllowMultiSelect = False
    With .Filters
      .Clear
      .Add "Excel Files", "*.xl*"
    End With
    If .Show = False Then
      cancelled = True
      Exit Sub
    End If
    strTemplatePath = .SelectedItems(1)
  End With
  
  Set wkbTemp = Application.Workbooks.Open(strTemplatePath)
  wkbTemp.Activate
  
  ' get ranges to populate
  For iCount = LBound(strMergeFields) To UBound(strMergeFields)
    On Error Resume Next
    Set rngTemp = Application.InputBox( _
        Prompt:="Select range(s) to populate with " & _
                rngSourceRange.Rows(1).Cells(iCount) & ". " & vbCrLf & _
                "Hold Ctrl to select multiple cells.", _
        Title:="Merge: Select Merge Fields", _
        Type:=8)
    On Error GoTo 0
    If rngTemp Is Nothing Then
      cancelled = True
      Exit Sub
    End If
    strMergeFields(iCount) = rngTemp.Address
    If Len(strSheetName) = 0 Then
      strSheetName = Application.ActiveWorkbook.ActiveSheet.Name
    Else
      If (strSheetName <> Application.ActiveWorkbook.ActiveSheet.Name) Then
        cancelled = True
        Call MsgBox("Merge fields must be on the same sheet.", _
            vbOKOnly + vbCritical, "Merge: Error")
        wkbTemp.Close (False)
        Exit Sub
      End If
    End If
  Next iCount
  
  wkbTemp.Close (False)
End Sub

Public Sub doMerge()
  Dim iSourceRow As Long
  Dim iFieldNum As Long
  
  Dim wkbTemp As Excel.Workbook
  Dim wshTemp As Excel.Worksheet
  Dim strTemp As String
  
  Call initGlobals
  If (cancelled) Then Exit Sub
  
  Dim answer As VBA.VbMsgBoxResult
  
  answer = MsgBox("Create separate workbook for each record?", _
            vbYesNoCancel, "How you wanna *** it?")
  
  If answer = vbCancel Then Exit Sub
  
  Application.ScreenUpdating = False
  
  If answer = vbNo Then
    Set wkbTemp = Application.Workbooks.Add(strTemplatePath)
  End If
  ' go through all row records
  For iSourceRow = 2 To rngSourceRange.Rows.Count
    ' make a new workbook based on template
    If answer = vbYes Then
      Set wkbTemp = Application.Workbooks.Add(strTemplatePath)
      Set wshTemp = wkbTemp.Worksheets(strSheetName)
    Else
      wkbTemp.Worksheets(strSheetName).Copy _
          after:=wkbTemp.Worksheets(wkbTemp.Worksheets.Count)
      Set wshTemp = wkbTemp.Worksheets(wkbTemp.Worksheets.Count)
    End If
    
    ' populate fields
    For iFieldNum = LBound(strMergeFields) To UBound(strMergeFields)
      wshTemp.Range(strMergeFields(iFieldNum)).Value = _
          rngSourceRange.Cells(iSourceRow, iFieldNum).Value
    Next iFieldNum
    
    If answer = vbYes Then
      ' make a name for the new merge
      strTemp = ThisWorkbook.Path
      If Right$(strTemp, 1) <> "\" Then
        strTemp = strTemp & "\"
      End If
      strTemp = strTemp & Format(Now(), "yyyy-mm-dd_hhmmss_") & "merge_" & iSourceRow - 1
      
    ' save the file and close
      wkbTemp.SaveAs strTemp, ThisWorkbook.FileFormat
      wkbTemp.Close False
    End If
  Next iSourceRow
  
  If answer = vbNo Then
      ' make a name for the new merge
      strTemp = ThisWorkbook.Path
      If Right$(strTemp, 1) <> "\" Then
        strTemp = strTemp & "\"
      End If
      strTemp = strTemp & Format(Now(), "yyyy-mm-dd_hhmmss_") & "merge"
      
      Application.DisplayAlerts = False
      wkbTemp.Worksheets(strSheetName).Delete
      Application.DisplayAlerts = True
    ' save the file and close
      wkbTemp.SaveAs strTemp, ThisWorkbook.FileFormat
      wkbTemp.Close False
  End If
  
  Application.ScreenUpdating = False
  
  Call MsgBox("Merge completed!", vbOKOnly + vbInformation, "Merge: Completed")
End Sub

Thanks for your expertize and time.

Hi Joshi...

I've looked at your Workbooks and the Code. I have no clue what your current Code is doing or why. I click on the "Click Me" Button, select a range (including the Header Row) and it brings up a screen asking me to select a File. Why am I selecting a File...based on your description I thought you were creating Files. I don't understand the process. In addition, what's the Template File for?

You'll need to explain to this mere mortal what you're doing and why before this mere mortal can modify Code that this mere mortal has not written.

Hi John,

Thanks for your reply and time. The template file for creating separate files in same format as per rows data from "MailMerge" workbook (Cell "B2", "D2","F2","C3" & F3" will change based on Rows data from workbook "MailMerge"). Please click on the button and select the Template file then select the appropriate filed (Cell "B2", "D2","F2","C3" & F3") then the Macro will create separate excel files with file name as current date and time. I want to save these files to PDF format and the file name would be cell values of "D2" & "B2 & "F3" from Template workbook.

Hi Joshi

Is Merge Field 1 ALWAYS going to go to Cell B2?
Is Merge Field 2 ALWAYS going to go to Cell D2?
Is Merge Field 3 ALWAYS going to go to Cell C3?
Is Merge Field 4 ALWAYS going to go to Cell F2?
Is Merge Field 5 ALWAYS going to go to Cell F3?

Hi John,
Yes it is.

Hi Joshi

Your process confuses me...if those items ALWAYS go the same place, why are you asking the User where to put them?

Hi John,
Some times the template may change, and the field may change that's why I am asking that.

So, your answer to this question is NO?

Is Merge Field 1 ALWAYS going to go to Cell B2?
Is Merge Field 2 ALWAYS going to go to Cell D2?
Is Merge Field 3 ALWAYS going to go to Cell C3?
Is Merge Field 4 ALWAYS going to go to Cell F2?
Is Merge Field 5 ALWAYS going to go to Cell F3?

Sorry John, really sorry for the inconvenienced.

Hi Joshi

Try the Code in the attached. I've modified the Code in Public Sub doMerge() to export the newly created files as PDF. Let me know of issues.

Hi John,

Excellent.. code... Its working great... Thank you so much.

Hi Joshi

I see you had second thoughts...good for you...

Thanks John,

I have tried and able to do that by modifying the code as below. is it correct, please advise.

strTemp = Range(strMergeFields(2)).Value & "-" & Range(strMergeFields(1)).Value & "-" & Range(strMergeFields(5)).Value

Hi Joshi

is it correct, please advise.

Does it work? Proof is in the pudding...

Hi John,
Yes its working great. Thank you so much once again.

Hi, I need to know how this is working. Doesnt work for me. I am trying to do MailMerge from an Excel file and need to cut all files as PDF thus renaming them as per the EmployeeID, Department etc. What do I need to do to the file attached above? I am using Excel2010

Hi Sachin,

Please upload your data file and template file. I will look at it. Sure I can help you. Better you start as new thread since this thread marked as SOLVED

Hi Joshi, thanks. I have already started a new thread but saw this post so commented here as well.

My code is below : I am trying to automate empCount which is total of all records and PATH. I have to edit these manually everytime. Alternatively I can work with your code as well.

--------------------------------------

Sub Macro1()
'
' Macro1 Macro
'
'
empCount = 423
dirCommon = "C:\Users\anilri\Desktop\Letters\"

Dim fieldLoop As Field

If ActiveDocument.MailMerge.ViewMailMergeFieldCodes = -1 Then
ActiveDocument.MailMerge.ViewMailMergeFieldCodes = wdToggle
End If

ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord

For ctr = 1 To empCount

For Each fieldLoop In ActiveDocument.Fields
If InStr(1, fieldLoop.Code.Text, "Division", 1) Then
division = fieldLoop.Result
End If
If InStr(1, fieldLoop.Code.Text, "Director", 1) Then
mgrName = fieldLoop.Result
End If
If InStr(1, fieldLoop.Code.Text, "Emp_Name", 1) Then
empName = fieldLoop.Result
End If
If InStr(1, fieldLoop.Code.Text, "Emp_Number", 1) Then
empId = fieldLoop.Result
End If
Next fieldLoop

ActiveDocument.ExportAsFixedFormat OutputFileName:= _
dirCommon & division & " - " & mgrName & " - " & empName & "(" & empId & ").pdf", ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False


ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord

Next ctr


End Sub