Excel VBA Mailmerge使用多个Word模板

编程问答 2022-06-11

问题描述

问题：

我想基于Excel列中的单元格值，使用2个不同的字母模板来创建字母。

我的问题是以下问题的扩展：

VBA Automated Mailmerge using 2 templates based on cell value

示例：

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

enter image description here

@ 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","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

请求：

不幸的是，问题的原始发帖人没有共享他的“ SaveIndividualWordFiles”宏。

当我只有一个字母模板时，我试图用通常用于从Word进行邮件合并的VBA的部分来填补空白。 （见下文）

但是我不能把它们拼在一起。

Sub Merge_To_Individual_Files()
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 & Application.PathSeparator
  For i = 1 To .MailMerge.DataSource.RecordCount
    With .MailMerge
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        If Trim(.datafields("Col A")) = "" Then Exit For
        StrName = .datafields("Col A") & " " & .datafields("Col C")
      End With
      .Execute Pause:=False
      If Err.Number = 5631 Then
        Err.Clear
        GoTo NextRecord
      End If
    End With
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName,Mid(StrNoChr,j,1),"_")
      Next
    StrName = Trim(StrName)
    With ActiveDocument
      .SaveAs FileName:=StrFolder & StrName & ".docx",FileFormat:=wdFormatXMLDocument,AddToRecentFiles:=False
      .SaveAs FileName:=StrFolder & StrName & ".pdf",FileFormat:=wdFormatPDF,AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
NextRecord:
  Next i
End With
Application.ScreenUpdating = False
End Sub

感谢您的帮助。

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

excelexcelmailmergems-wordvba