如何解决Excel VBA Mailmerge使用多个Word模板
问题:
我想基于Excel列中的单元格值,使用2个不同的字母模板来创建字母。
我的问题是以下问题的扩展:
VBA Automated Mailmerge using 2 templates based on cell value
示例:
在下面的示例中,C列中的值应指示每行将使用哪个字母模板。 (如果单元格值为YES,请使用字母模板“ 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","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 举报,一经查实,本站将立刻删除。