使用2个基于单元格值的模板的VBA自动邮件合并 [英] VBA Automated Mailmerge using 2 templates based on cell value

问题描述

场景:我有一个电子表格，用于通过自动邮件合并宏生成信件.跨页通常包含约2000行

问题:我需要具有根据列中的单元格值使用2个不同字母模板创建字母的能力.在下面的示例中，C列上的值应指示每行将使用哪个字母模板.

示例

  Col A Col B Col C约翰·史密斯是信模板1Joe Henricks不使用信模板2马克·琼斯(Mark Jones)是信模板1 

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

这是我正在使用的一些VBA，但不能完全使它适用于2个不同的字母.

我也尝试过使用IF，THEN，ELSE语句，但仍然无法使其工作

 子CommandButton2_Click()Selection.AutoFilter''''''''''这应该基于YES值过滤所有行ActiveSheet.Range("D1:AH1").AutoFilter字段:= 31，条件1:= _是的"'''''''''''''''''''''''''''''''''''''''昏暗的WordApp作为对象调光范围范围("A1:H1").选择设置rng = Application.Intersect(ActiveSheet.UsedRange，Range("D1:AH1"))rng.SpecialCells(xlCellTypeVisible).选择关于错误继续设置WordApp = GetObject(，"Word.Application")出错时转到0如果WordApp一无所获设置WordApp = CreateObject("Word.Application")万一'''这应该使用YESletter模板运行宏WordApp.Visible =假WordApp.Documents.Open"\\ .... \ docs \ lg \ Letterbuilder \ YESletter.docm"WordApp.Run"Module1.SaveIndividualWordFiles"'''''''''''''''''''''''''''''''''''''''Selection.AutoFilter''''''''''这应该基于NO值过滤所有行ActiveSheet.Range("D1:AH1").AutoFilter字段:= 31，条件1:= _邮政"'''''''''''''''''''''''''''''''''''''''关于错误继续设置WordApp = GetObject(，"Word.Application")出错时转到0如果WordApp一无所获设置WordApp = CreateObject("Word.Application")万一'''这应该使用NOletter模板运行宏WordApp.Visible =假WordApp.Documents.Open"\\ .... \ docs \ lg \ Letterbuilder \ NOletter.docm"WordApp.Run"Module1.SaveIndividualWordFiles"结尾 

这是IF，THEN，ELSE语句方法

 如果ThisWorkbook.Sheets("LetterData").Range("AH").Value ="YES"然后WordApp.Visible =假WordApp.Documents.Open"\\ .... \ docs \ lg \ Letterbuilder \ YESletter.docm"WordApp.Run"Module1.SaveIndividualWordFiles"别的WordApp.Visible =假WordApp.Documents.Open"\\ .... \ docs \ lg \ Letterbuilder \ NOletter.docm"WordApp.Run"Module1.SaveIndividualWordFiles"结尾 

解决方案

您的代码中存在一些主要缺陷:

• 要打开具有给定模板的Word文档，您必须使用 Documents 对象 Add()方法代替 Open()一个

• Word模板文档的扩展名为".dot"或".dotx"，而不是我在代码中看到的".docm"

• 仅设置一个Word应用程序，并在整个宏中使用它

  并最终通过

处置"它

• 最后，切勿使用 End 语句

  只需使用 End Sub

因此，这里遵循一个可能的代码:

 选项显式子CommandButton2_Click()昏暗的wordApp作为对象设置wordApp = GetWordObject'<-|得到一个Word对象如果wordApp什么都没有，则退出Sub'<-|如果没有Word对象，则退出sub使用ThisWorkbook.Sheets("LetterData")'<-|参考您的信函工作表使用Application.Intersect(.UsedRange，Range("D1:AH1").EntireColumn)'<-|参照参考工作表列D:H中使用的范围来引用您的数据范围CreateWordDocuments .Cells，是"，wordApp，"\\ .... \ docs \ lg \ Letterbuilder \ YESletter.dotx"'<-|处理是"文件CreateWordDocuments .Cells，否"，wordApp，"\\ .... \ docs \ lg \ Letterbuilder \ NOletter.dotx"'<-|处理否"文件结束于.AutoFilterMode = False'<-|向后显示所有行并删除自动过滤器结束于'处理"一词wordApp.Quit True'<-|退出Word并保存更改以打开文档设置wordApp = Nothing结束子Sub CreateWordDocuments(dataRng作为范围，标准作为字符串，wordApp作为对象，templateDocPath作为字符串)暗单元格范围使用dataRng'<-|参考数据范围.AutoFilter字段:= 31，criteria1:=准则'<-|使用给定条件在其第31列中对其进行过滤如果Application.WorksheetFunction.Subtotal(103，.Resize(，1))>1然后'<-|是否已过滤任何单元格对于.Offset(1).Resize(.Rows.Count-1，1).SpecialCells(xlCellTypeVisible)'<-|中的每个单元格循环通过过滤的单元格wordApp.Documents.Add templateDocPath'<-打开传递的Word模板wordApp.Run"Module1.SaveIndividualWordFiles"'<-|运行你的宏下一个单元格万一结束于结束子函数GetWordObject()作为对象昏暗的wordApp作为对象关于错误继续设置wordApp = GetObject(，"Word.Application")'<-|尝试获取正在运行的Word应用程序出错时转到0如果wordApp什么都没有，则设置wordApp = CreateObject("Word.Application")'<-|如果找不到正在运行的Word实例，则打开一个新实例设置GetWordObject = wordApp'<-|返回设置的Word应用程序wordApp.Visible = False结束功能 

顺便说一句:

• 您的数据示例提到了 Col A ， Col B 和 Col C ，但是您的代码使用范围表格列"D"到"AH"

  我认为这是后者

• 您的代码中包含带有 Criteria1:="Post"

  的语句

  我以是"和否"为唯一条件

但是所有这些方面都可以在建议的代码中轻松设置

Scenario: I have a spreadsheet used for generating letters via an automated mail merge macro. The spread typically contains about 2000 rows

Problem: I need to have the ability to create letters using 2 different letter templates based on cell values in a column. In the example below, the value on column C should dictate which letter template will be used for each row.

Example

      Col A        Col B            Col C
      John         Smith           YES           Letter Template 1 to be used
      Joe            Henricks      No            Letter Template 2  to be used
       Mark        Jones            YES          Letter Template 1  to be used

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Here is some VBA I was playing with but can't quite get it working for the 2 different letters.

I've also tried using IF, THEN, ELSE statements but still can't get it working

   Sub CommandButton2_Click()

   Selection.AutoFilter   '''''''''' This should filter all rows based on the YES value 
    ActiveSheet.Range("D1:AH1").AutoFilter Field:=31, Criteria1:= _
    "YES"

     '''''''''''''''''''''''''''''''''''''''''

   Dim WordApp As Object
   Dim rng As Range
   Range("A1:H1").Select

    Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("D1:AH1"))
    rng.SpecialCells(xlCellTypeVisible).Select


   On Error Resume Next
   Set WordApp = GetObject(, "Word.Application")
   On Error GoTo 0

   If WordApp Is Nothing Then
   Set WordApp = CreateObject("Word.Application")
   End If
    ''' This should run the macro using the YESletter Template
           WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\YESletter.docm""
   WordApp.Run "Module1.SaveIndividualWordFiles"


   '''''''''''''''''''''''''''''''''''''''''

   Selection.AutoFilter   '''''''''' This should filter all rows        based        on        the NO value 
ActiveSheet.Range("D1:AH1").AutoFilter Field:=31, Criteria1:= _
    "Post"

   '''''''''''''''''''''''''''''''''''''''''

   On Error Resume Next
   Set WordApp = GetObject(, "Word.Application")
   On Error GoTo 0

   If WordApp Is Nothing Then
   Set WordApp = CreateObject("Word.Application")
   End If

    ''' This should run the macro using the NOletter Template
           WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\NOletter.docm"
   WordApp.Run "Module1.SaveIndividualWordFiles"

   End

Here's the IF, THEN, ELSE statement method

   If ThisWorkbook.Sheets("LetterData").Range("AH").Value = "YES" Then

       WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\YESletter.docm"
   WordApp.Run "Module1.SaveIndividualWordFiles"

   ELSE

       WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\NOletter.docm"
   WordApp.Run "Module1.SaveIndividualWordFiles"

   End

解决方案

there are some major flaws in your code:

• to open a Word document with a given template you must use Documents object Add() method, instead of Open() one

• Word templates documents have ".dot" or ".dotx" extension, instead of ".docm" I see in your code

• set only one Word application and use it throughout your macro

  and eventually "dispose" it with

• finally, never use End statement

  just use End Sub

so here follows a possible code:

Option Explicit

Sub CommandButton2_Click()
    Dim wordApp As Object

    Set wordApp = GetWordObject '<--| get a Word object
    If wordApp Is Nothing Then Exit Sub '<--| if no Word Object has been gotten then exit sub

    With ThisWorkbook.Sheets("LetterData") '<--| reference your letter worksheet
        With Application.Intersect(.UsedRange, Range("D1:AH1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
            CreateWordDocuments .Cells, "YES", wordApp, "\\....\docs\lg\Letterbuilder\YESletter.dotx" '<--| process "YES" documents
            CreateWordDocuments .Cells, "NO", wordApp, "\\....\docs\lg\Letterbuilder\NOletter.dotx" '<--| process "NO" documents
        End With
        .AutoFilterMode = False '<--| show all rows back and remove autofilter
    End With

    '"dispose" Word
    wordApp.Quit True '<--| quit Word and save changes to open documents
    Set wordApp = Nothing
End Sub

Sub CreateWordDocuments(dataRng As Range, criteria As String, wordApp As Object, templateDocPath As String)
    Dim cell As Range
    With dataRng '<--| reference data range
        .AutoFilter Field:=31, criteria1:=criteria '<--| filter it on its column 31 with given criteria
        If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell has been filtered
            For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) '<--| loop through filtered cells
                wordApp.Documents.Add templateDocPath '<-- open the passed Word template
                wordApp.Run "Module1.SaveIndividualWordFiles" '<--| run your macro
            Next cell
        End If
    End With
End Sub

Function GetWordObject() As Object
    Dim wordApp As Object

    On Error Resume Next
    Set wordApp = GetObject(, "Word.Application") '<--| try getting a running Word application
    On Error GoTo 0
    If wordApp Is Nothing Then Set wordApp = CreateObject("Word.Application") '<--| if no running instance of Word has been found then open a new one

    Set GetWordObject = wordApp '<--| return the set Word application
    wordApp.Visible = False
End Function

BTW:

• your data example mentions Col A, Col B and Col C, but your code uses a range form column "D" to "AH"

  I assumed this latter

• your code has a statement with Criteria1:="Post"

  I assumed "YES" and "NO" as the only criteria

but all these aspects are easily settable in the proposed code

这篇关于使用2个基于单元格值的模板的VBA自动邮件合并的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！