Results 1 to 18 of 18

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

Threaded View

  1. #1
    Forum Contributor
    Join Date
    10-30-2011
    Location
    Doha
    MS-Off Ver
    MS office 365
    Posts
    701

    Question 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.
    Attached Files Attached Files
    Cheers,

    Joshi
    Being with a winner makes you a winner

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1