Microsoft Office Forums - View Single Post

macropod · 02-28-2025, 04:04 AM

Delete Unwanted Rows from a Mailmerge Table
In a mailmerge with a table with a row that may or may not be required, it’s fairly simple to use field coding like:
{IF«condition»= TRUE "
Table for true condition goes here
" "
Table for false condition goes here
"}
This approach is easy-enough to implement where there are perhaps no more than 3 conditional rows. For larger tables, though, where the number of permutations becomes problematic, a macro that intercepts the 'Finish & Merge>Edit Individual Documents' command to execute the merge then goes through the output document and delete any table rows where a given cell is empty is a simpler approach. The following macro does just that, deleting rows whose cell in column 2 is empty. You could test a different column by changing the 2 in .Cell(r, 2). The two commented-out code lines would be used if the intention is to print the output rather than save it. More sophisticated code could be used to test different cells on various rows or in different tables.

Code:

Sub MailMergeToDoc()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim t As Long, r As Long
ActiveDocument.MailMerge.Destination = wdSendToNewDocument
ActiveDocument.MailMerge.Execute
With ActiveDocument
  For t = 1 To .Tables.Count
    With .Tables(t)
      For r = .Rows.Count To 2 Step -1
        'To delete the row if a particular cell (in this case, in column 2) is empty:
        If Split(.Cell(r, 2).Range.Text, vbCr) = "" Then .Rows(r).Delete
        'To delete the row if a particular cell (in this case, in column 2) contains just '$0.00':
        If Split(.Cell(r, 2).Range.Text, vbCr) = "$0.00" Then .Rows(r).Delete
        'To delete the row if the entire row is empty:
        If Len(.Rows(r).Range.Text) = .Rows(r).Cells.Count * 2 + 2 Then .Rows(r).Delete
      Next
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

Simply comment-out or delete the unwanted row deletion code lines and edit the remaining code line to suit your scenario.

If merging direct to print, change the macro name to 'MailMergeToPrinter' and insert:

Code:

  .PrintOut
  .Close False

before the final:

Code:

End With

Prevent Line Wrapping in Label Merges
In a label merge, it is sometimes desirable to prevent line wrapping - such as when creating address labels. The following macro ensures the output on each label in a mailmerge contains no line wrapping. Text that is too long to fit on a single line is fitted to the cell’s width.

Code:

Sub MailMergeToDoc()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim Tbl As Table, Cll As Cell, Par As Paragraph, sCllWdth As Single, sParWdth As Single
With ActiveDocument
  With .Tables(1)
    For Each Cll In .Range.Cells
      Cll.WordWrap = False
    Next
    With .Cell(1, 1)
      sCllWdth = .Width - .LeftPadding - .RightPadding
    End With
  End With
  .MailMerge.Execute
End With
With ActiveDocument
  For Each Tbl In .Tables
    For Each Cll In Tbl.Range.Cells
      If Len(Cll.Range) > 2 Then
        For Each Par In Cll.Range.Paragraphs
          With Par.Range
            sParWdth = .Characters.Last.Previous.Information(wdHorizontalPositionRelativeToPage)
            sParWdth = sParWdth - .Characters.First.Information(wdHorizontalPositionRelativeToPage)
            If sParWdth + .LeftIndent > sCllWdth Then .FitTextWidth = sCllWdth - .LeftIndent
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = sCllWdth - .LeftIndent
            End If
          End With
        Next
      End If
    Next
  Next
End With
Application.ScreenUpdating = True
End Sub

Note: For this approach to work, the required separate lines in the labels must be separated by paragraph breaks.

If merging direct to print, change the macro name to 'MailMergeToPrinter' and insert:

Code:

  .PrintOut
  .Close False

before the final:

Code:

End With

Activate Plain-Text Email Addresses & Hyperlinks
If you insert a HYPERLINK field into another field (e.g. as part of an IF test) the hyperlink will be inactive in the output document. For example:
{IF«balance_due»= "0.00" "Thanks for paying your invoice" "Please pay your invoice online {HYPERLINK "https://MySite.com/pay inv=«inv_number»&amountt=«inv_amount»"}"}
won't give you a working hyperlink. To overcome that limitation, you could code the mergefield along the lines of:
{IF«balance_due»= "0.00" "Thanks for paying your invoice" "Please pay your invoice online, at: https://MySite.com/pay?inv=«inv_number»&amountt=«inv_amount»"}
and add the following macro to your mailmerge main document. Clicking on the 'Edit Individual Documents' button will intercept the merge and convert any email and hyperlink strings in the output document to working hyperlinks.

Code:

Sub MailMergeToDoc()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim bHead As Boolean, bList As Boolean, bBullet As Boolean, _
  bOther As Boolean, bQuote As Boolean, bSymbol As Boolean, _
  bOrdinal As Boolean, bFraction As Boolean, bEmphasis As Boolean, _
  bHLink As Boolean, bStyle As Boolean, bMail As Boolean, bTag As Boolean
'Store the current autoformat options
With Options
  bHead = .AutoFormatApplyHeadings
  bList = .AutoFormatApplyLists
  bBullet = .AutoFormatApplyBulletedLists
  bOther = .AutoFormatApplyOtherParas
  bQuote = .AutoFormatReplaceQuotes
  bSymbol = .AutoFormatReplaceSymbols
  bOrdinal = .AutoFormatReplaceOrdinals
  bFraction = .AutoFormatReplaceFractions
  bEmphasis = .AutoFormatReplacePlainTextEmphasis
  bHLink = .AutoFormatReplaceHyperlinks
  bStyle = .AutoFormatPreserveStyles
  bMail = .AutoFormatPlainTextWordMail
  bTag = .LabelSmartTags
End With
'Restrict autoformating to emails and hyperlinks
With Options
  .AutoFormatApplyHeadings = False
  .AutoFormatApplyLists = False
  .AutoFormatApplyBulletedLists = False
  .AutoFormatApplyOtherParas = False
  .AutoFormatReplaceQuotes = False
  .AutoFormatReplaceSymbols = False
  .AutoFormatReplaceOrdinals = False
  .AutoFormatReplaceFractions = False
  .AutoFormatReplacePlainTextEmphasis = False
  .AutoFormatReplaceHyperlinks = True
  .AutoFormatPreserveStyles = False
  .AutoFormatPlainTextWordMail = True
  .LabelSmartTags = False
End With
'Execute the Mailmerge
ActiveDocument.MailMerge.Execute
'Apply the autoformating to the output document
ActiveDocument.Range.AutoFormat
'Restore the original autoformat options
With Options
  .AutoFormatApplyHeadings = bHead
  .AutoFormatApplyLists = bList
  .AutoFormatApplyBulletedLists = bBullet
  .AutoFormatApplyOtherParas = bOther
  .AutoFormatReplaceQuotes = bQuote
  .AutoFormatReplaceSymbols = bSymbol
  .AutoFormatReplaceOrdinals = bOrdinal
  .AutoFormatReplaceFractions = bFraction
  .AutoFormatReplacePlainTextEmphasis = bEmphasis
  .AutoFormatReplaceHyperlinks = bHLink
  .AutoFormatPreserveStyles = bStyle
  .AutoFormatPlainTextWordMail = bMail
  .LabelSmartTags = bTag
End With
Application.ScreenUpdating = True
End Sub

Send Mailmerge Output to Individual Files
By adding the following macro to your mailmerge main document, you can generate one output file per record. Files are saved to the same folder as the mailmerge main document, using the 'Last_Name' & 'First_Name' fields in the data source for the filenames (change these to suit your needs). PDF & DOCX formats are catered for, as is inserting the record name into the footer. You can comment-out/delete whichever of those lines isn't applicable to your situation.

Code:

Sub Merge_To_Individual_Files()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
  StrFolder = .Path & "\"
  With .MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    On Error Resume Next
    For i = 1 To .DataSource.RecordCount
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        If Trim(.DataFields("Last_Name")) = "" Then Exit For
        'StrFolder = .DataFields("Folder") & "\"
        StrName = .DataFields("Last_Name") & "_" & .DataFields("First_Name")
      End With
      On Error GoTo NextRecord
      .Execute Pause:=False
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
      Next
      StrName = Trim(StrName)
      With ActiveDocument
        'Add the name to the footer
        '.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
        .SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
        ' and/or:
        .SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        .Close SaveChanges:=False
      End With
NextRecord:
    Next i
  End With
End With
Application.ScreenUpdating = True
End Sub

Note 1: If you rename the above macro as 'MailMergeToDoc', clicking on the 'Edit Individual Documents' button will intercept the merge and the process will run automatically. The potential disadvantage of intercepting the 'Edit Individual Documents' process this way is that you no longer get to choose which records to merge at that stage. However, you can still achieve the same outcome - and with greater control - via the 'Edit Recipient List' tools.

Note 2: If you're using Word 2007 or later, your mailmerge main document will need to be saved in the .doc or .docm formats, as documents using the .docx format cannot contain macros.

Note 3: The above code defaults to saving the output to the mailmerge main document's folder. You can change the destination folder by editing:

Code:

StrFolder = .Path & "\"

If destination folders are specified in the data source, you could delete or comment-out that line and un-comment the line:

Code:

'StrFolder = .DataFields("Folder") & "\"

where the folder the output is to be saved to is in a data field named 'Folder'.

If there is a risk that the output folder does not exist, it can be created on the fly by adding:

Code:

If Dir(StrFolder) = "" Then MkDir StrFolder

Alternatively, to save the output to the same folder as the data source, you could replace:

Code:

StrFolder = .Path & "\"

with:

Code:

StrFolder = .MailMerge.DataSource.Name
i = InStrRev(StrFolder, "\")
StrFolder = Left(StrFolder, i)

Illegal filename characters are replaced with underscores.

Note 4: The above code also provides for the filename to be output to the page footer. This, of course, assumes the footer is suitably formatted. Simply uncomment the line concerned.

Run a Mailmerge from Excel, Sending the Output to Individual Files
The following macro automates a mailmerge from Excel. The code assumes you have a document named 'MailMergeMainDocument.docx' stored in the same folder as the Excel workbook. That document should not contain macros or protection and should be saved as an ordinary document or as a mailmerge main document.

As coded, the macro also assumes a standard query, processing all records from Sheet1. Change the sheet references, as appropriate. If you're using filtering, you'd have to add that to the macro's SQLStatement, too.

Each record's output is sent to a new file in the same folder as the Excel workbook, using the 'Last_Name' & 'First_Name' fields in the data source for the filenames (change these to suit your requirements). Illegal filename characters are replaced with underscores.

Code:

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 & "MailMergeMainDocument.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("LAST_NAME")) = "" Then Exit For
        StrName = .DataFields("LAST_NAME") & "_" & .DataFields("FIRST_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

Note 1: For testing purposes, you might want to change the line 'wdApp.Visible = False' to 'wdApp.Visible = True'.

Note 2: The above code also provides for the filename to be output to the page footer. This, of course, assumes the footer is suitably formatted. Simply uncomment the line concerned.

Note 3: The above code defaults to saving the output to the workbook's folder. You can change that by editing:

Code:

StrMMPath = ThisWorkbook.Path & "\"

For example, to save the output to the user's 'Documents' folder, you could use:

Code:

StrMMPath = "C:\Users\" & Environ("Username") & "\Documents\"

If you already have a mailmerge main document set up with (or without) filtering, you could use the following Word macro to retrieve the SQL statement:

Code:

Sub GetSQL()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
With ActiveDocument.MailMerge
  If .MainDocumentType <> wdNotAMergeDocument Then
    MsgBox "Mail Merge Query String:" & vbCr & .DataSource.QueryString
  Else
    MsgBox "Not A Merge Document"
  End If
End With
End Sub

Split Merged Output to Separate Documents
Execute the merge, sending the output to a new document, then run the following macro over that document.

Code:

Sub SplitMergedDocument()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Const StrNoChr As String = """*./\:?|"
j = InputBox("How many Section breaks are there per record?", "Split By Sections", 1)
With ActiveDocument
   ' Process each Section
  For i = 1 To .Sections.Count - 1 Step j
    With .Sections(i)
       '*****
       ' Get the 1st paragraph's text
      StrTxt = Split(.Range.Paragraphs(1).Range.Text, vbCr)(0)
      For k = 1 To Len(StrNoChr)
        StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
      Next
       ' Construct the destination file path & name
      StrTxt = ActiveDocument.Path & "\" & StrTxt
       '*****
       ' Get the whole Section
      Set Rng = .Range
      With Rng
        If j > 1 Then .MoveEnd wdSection, j - 1
         'Contract the range to exclude the Section break
        .MoveEnd wdCharacter, -1
         ' Copy the range
        .Copy
      End With
    End With
     ' Create the output document
    Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
    With Doc
       ' Paste contents into the output document, preserving the formatting
      .Range.PasteAndFormat (wdFormatOriginalFormatting)
       ' Delete trailing paragraph breaks & page breaks at the end
      While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
        .Characters.Last.Previous = vbNullString
      Wend
       ' Replicate the headers & footers
      For Each HdFt In Rng.Sections(j).Headers
        .Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
      Next
      For Each HdFt In Rng.Sections(j).Footers
        .Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
      Next
       ' Save & close the output document
      .SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
       ' and/or:
      .SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

Illegal filename characters are replaced with underscores.

As coded, it is assumed the output filename consists of the first paragraph in each record. If not, you could use a different range or replace all of the content between the ***** strings with code like

Code:

        ' Construct the destination file path & name
        StrTxt = ActiveDocument.Path & "\" & (i + j - 1) / j

Convert Text Representations of Fields to Working Fields
The following macro converts text representations of Word field codes to working field codes. To do the conversion, simply paste the "textual" field codes into your document, select them and run the macro. Tabs, line breaks and paragraph breaks represented by the →, ↵ and ¶ symbols are converted to real tabs, line breaks and paragraph breaks, respectively.

Code:

Sub FieldStringToCode()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Dim RngFld As Range, RngTmp As Range, oFld As Field, bFldCodes As Boolean, StrTmp As String
If Selection.Type <> wdSelectionNormal Then _
  MsgBox "Select the text to convert and try again.", vbExclamation + vbOKOnly, "Error!": Exit Sub
If InStr(1, Selection.Text, "{") = 0 Or InStr(1, Selection.Text, "}") = 0 Then _
  MsgBox "There are no field strings in the selected range.", vbCritical + vbOKOnly, "Error!": Exit Sub
If (Len(Replace(Selection.Text, "{", vbNullString)) <> Len(Replace(Selection.Text, "}", vbNullString))) Or _
  (Len(Replace(Selection.Text, "«", vbNullString)) <> Len(Replace(Selection.Text, "»", vbNullString))) Then _
  MsgBox "Unmatched field brace pairs in the selected range.", vbCritical + vbOKOnly, "Error!": Exit Sub
TrkStatus = ActiveDocument.TrackRevisions: ActiveDocument.TrackRevisions = False
Application.ScreenUpdating = False
ActiveDocument.ActiveWindow.View.ShowFieldCodes = True
Set RngFld = Selection.Range
With RngFld
  .Text = Replace(Replace(Replace(Replace(Replace(.Text, vbCr, ""), Chr(11), ""), ChrW(&H2192), vbTab), ChrW(&H21B5), Chr(11)), Chr(182), vbCr)
  .End = .End + 1
  With .Duplicate.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Text = "»"
    .Replacement.Text = "}"
    .Execute Replace:=wdReplaceAll
    .Forward = False
    .Wrap = wdFindStop
    .Text = "«"
    .Replacement.Text = "{MERGEFIELD "
    .Execute Replace:=wdReplaceAll
  End With
  Do While InStr(1, .Text, "{") > 0
    Set RngTmp = ActiveDocument.Range(Start:=.Start + _
        InStr(.Text, "{") - 1, End:=.Start + InStr(.Text, "}"))
    With RngTmp
      Do While Len(Replace(.Text, "{", vbNullString)) <> Len(Replace(.Text, "}", vbNullString))
        .End = .End + 1
        If .Characters.Last.Text <> "}" Then .MoveEndUntil Cset:="}", _
          Count:=Len(ActiveDocument.Range(.End, RngFld.End))
      Loop
      .Characters.First = vbNullString: .Characters.Last = vbNullString: StrTmp = .Text
      Set oFld = ActiveDocument.Fields.Add(Range:=RngTmp, Type:=wdFieldEmpty, Text:="", PreserveFormatting:=False)
      oFld.Code.Text = StrTmp
    End With
  Loop
  ActiveDocument.TrackRevisions = TrkStatus
  ActiveDocument.ActiveWindow.View.ShowFieldCodes = bFldCodes
  .End = .End - 1
  If bFldCodes = False Then .Fields.ToggleShowCodes
  .Select
End With
Set RngTmp = Nothing: Set RngFld = Nothing: Set oFld = Nothing
Application.ScreenUpdating = False
End Sub

Note: Character formatting in the source string is not preserved.

Create Text Representations of Working Fields
The following macro creates text representations of Word field codes, regardless of how complex the fields might be, copying the text representation to the Windows Clipboard so you can paste it wherever you want. Simply select the field(s), then run the macro. Tabs, line breaks and paragraph breaks in the field code are converted to →, ↵ and ¶ symbols, respectively. The formatting of line breaks and paragraph breaks is approximated through the use of line breaks following the ↵ and ¶ symbols.

Code:

Sub FieldCodeToString()
Application.ScreenUpdating = False
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
' Note: A VBA reference to the MS Forms Object Library is required. See Tools|References in the VBE.
Dim StrOut As String, StrChr As String, i As Long, bDisp As Boolean, MyData As DataObject
With Selection
  If .Fields.Count = 0 Then MsgBox "No fields selected", vbExclamation: Exit Sub
  Do While .Characters.Last <> Chr(21)
    .End = .End - 1
  Loop
  Do While .Characters.First <> Chr(19)
    .Start = .Start + 1
  Loop
End With
With ActiveWindow
  bDisp = .View.ShowFieldCodes: .View.ShowFieldCodes = True
  For i = 1 To Len(Selection)
    StrChr = Mid(Selection, i, 1)
    Select Case StrChr
      Case Chr(9): StrChr = ChrW(&H2192)
      Case Chr(11): StrChr = ChrW(&H21B5) & Chr(11)
      Case Chr(13): StrChr = "¶" & Chr(11)
      Case Chr(19): StrChr = "{"
      Case Chr(21): StrChr = "}"
    End Select
    StrOut = StrOut + StrChr
  Next
  .View.ShowFieldCodes = bDisp
End With
Set MyData = New DataObject: MyData.SetText StrOut: MyData.PutInClipboard
Application.ScreenUpdating = True
End Sub

Note: As the field code is converted to a simple text string, character formatting is not preserved.