使用多个Word模板从Excel进行VBA邮件合并

问题：

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("Sheet1") '<--| reference your letter worksheet
        With Application.Intersect(.UsedRange, Range("A1:C1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
            CreateWordDocuments .Cells, "YES", wordApp, "C:\Users\camil\Desktop\YES.docx" '<--| process "YES" documents
            CreateWordDocuments .Cells, "NO", wordApp, "C:\Users\camil\Desktop\NO.docx" '<--| 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:=3, Criteria1:=criteria '<--| filter it on its column 3 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

我想根据Excel中列中的单元格值，使用两种不同的字母模板创建字母

---

我的问题是以下问题的延伸：

---

示例：

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("Sheet1") '<--| reference your letter worksheet
        With Application.Intersect(.UsedRange, Range("A1:C1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
            CreateWordDocuments .Cells, "YES", wordApp, "C:\Users\camil\Desktop\YES.docx" '<--| process "YES" documents
            CreateWordDocuments .Cells, "NO", wordApp, "C:\Users\camil\Desktop\NO.docx" '<--| 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:=3, Criteria1:=criteria '<--| filter it on its column 3 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

在下面的示例中，C列中的值应指示每行将使用哪个字母模板。（如果单元格值为是，则使用字母模板“YES.docx”，否则使用字母模板“No.docx”）

由@user3598756提出的解决方案（修改为上述示例）：

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("Sheet1") '<--| reference your letter worksheet
        With Application.Intersect(.UsedRange, Range("A1:C1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
            CreateWordDocuments .Cells, "YES", wordApp, "C:\Users\camil\Desktop\YES.docx" '<--| process "YES" documents
            CreateWordDocuments .Cells, "NO", wordApp, "C:\Users\camil\Desktop\NO.docx" '<--| 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:=3, Criteria1:=criteria '<--| filter it on its column 3 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

---

非常感谢您的帮助。

您真的不需要这么多的迂回。整个过程可以在一个mailmerge主文档中完成，该文档使用一个简单的IF字段来测试列C值并相应地修改输出。在mailmerge主文档中使用INCLUDETEXT字段同样简单，该字段使用C列的输出有条件地合并“是”和“否”文档。请参阅：@macrood I dit尝试在彼此内部生成5条if语句，包括所有合并字段。这对我来说很有效，但是当我把文档发送给同事时，他们不能使用它，因为他们只收到了最后一封合并的信。我花了几周的时间试图让我开始工作，现在我决定我的请求将是一种更可靠的方法，而且信件可以更容易地编辑。这很可能与IF测试无关，而是与mailmerge的执行有关。在任何情况下，如果您没有发布任何与IF测试相关的内容，就无法对其进行评论。@Macrood我再次阅读了您的建议，并尝试使用“includetext”字段。再一次，它在我自己的电脑上工作得非常好，而不是当我把它发给同事时。其中内容由最后一个合并的字母替换。我仍然更喜欢VBA方法，因为如果我开始工作，它会带来更少的问题。除非你有另一个建议来解决我的问题。这强烈表明你的同事有问题：计算机；或方法。VBA也不一定能克服，而且更难维护。