使用Excel VBA自动化邮件合并

我的名字是赫马，这是我的第一个macros，并在堆栈溢出第一篇文章。

我已经在Excel中创build了一个macros，我可以自动将Excel中的数据自动邮件合并到Word Letter Template中，并将单个文件保存到文件夹中。

我在Excel中有员工数据，我可以使用该数据生成任何员工信函，并可以根据员工姓名保存个人员工信函。

我已经成功地自动运行邮件合并，并按照员工姓名保存单个文件。 而且每次运行一个人的文件时，它都会给出信件已经生成的状态，以便它不会重复任何员工logging。

现在我唯一面临的问题是所有合并文件中的输出与第一行的输出相同。 示例：如果我的Excel有5个员工详细信息，我可以将每个员工姓名上的5个单独合并文件保存，但是只有第2行中的第一个员工才能合并数据。 数据显示在第一行员工的所有文件中。

我无法附加文件，但我的行有以下数据：行A：有S.No. 行B：具有Empl名称行C：具有处理date行D：具有地址行E：名字行F：业务标题行G：显示状态（如果生成的字母显示“已生成字母”如果是新logging，则显示空白。

也请求某人添加一个代码，在那里我可以保存输出（合并的文件）也在PDF文件以外的PDF文件。 所以合并的文件将采用两种格式，一种是Doc格式，另一种是PDF格式。

提前非常感谢你希望能尽快听取某人的意见。

Sub MergeMe() Dim bCreatedWordInstance As Boolean Dim objWord As Word.Application Dim objMMMD As Word.Document Dim EmployeeName As String Dim cDir As String Dim r As Long Dim ThisFileName As String lastrow = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row r = 2 For r = 2 To lastrow If Cells(r, 7).Value = "Letter Generated Already" Then GoTo nextrow EmployeeName = Sheets("Data").Cells(r, 2).Value ' Setup filenames Const WTempName = "letter.docx" 'This is the 07/10 Word Templates name, Change as req'd Dim NewFileName As String NewFileName = "Offer Letter - " & EmployeeName & ".docx" 'This is the New 07/10 Word Documents File Name, Change as req'd" ' Setup directories cDir = ActiveWorkbook.path + "\" 'Change if appropriate ThisFileName = ThisWorkbook.Name On Error Resume Next ' Create a Word Application instance bCreatedWordInstance = False Set objWord = GetObject(, "Word.Application") If objWord Is Nothing Then Err.Clear Set objWord = CreateObject("Word.Application") bCreatedWordInstance = True End If If objWord Is Nothing Then MsgBox "Could not start Word" Err.Clear On Error GoTo 0 Exit Sub End If ' Let Word trap the errors On Error GoTo 0 ' Set to True if you want to see the Word Doc flash past during construction objWord.Visible = False 'Open Word Template Set objMMMD = objWord.Documents.Open(cDir + WTempName) objMMMD.Activate 'Merge the data With objMMMD .MailMerge.OpenDataSource Name:=cDir + ThisFileName, sqlstatement:="SELECT * FROM `Data$`" ' Set this as required With objMMMD.MailMerge 'With ActiveDocument.MailMerge .Destination = wdSendToNewDocument .SuppressBlankLines = True With .DataSource .FirstRecord = wdDefaultFirstRecord .LastRecord = wdDefaultLastRecord End With .Execute Pause:=False End With End With ' Save new file objWord.ActiveDocument.SaveAs cDir + NewFileName ' Close the Mail Merge Main Document objMMMD.Close savechanges:=wdDoNotSaveChanges Set objMMMD = Nothing ' Close the New Mail Merged Document If bCreatedWordInstance Then objWord.Quit End If 0: Set objWord = Nothing Cells(r, 7).Value = "Letter Generated Already" nextrow: Next r End Sub 

问候，赫马

Answer 1

以PDF格式保存文件使用

 objWord.ActiveDocument.ExportAsFixedFormat cDir & NewFileName, _ ExportFormat:=wdExportFormatPDF 

在我看来，当你正在执行邮件合并，它应该创build一个文件与所有的信件，所以当你打开它，会出现第一个字母是得到保存，但如果你向下滚动您保存的单词文件，您可以在新页面上find每个字母。

相反，您要一次执行合并一个字母。
要解决此问题，请按如下所示更改行：

 With .DataSource .FirstRecord = r-1 .LastRecord = r-1 .ActiveRecord = r-1 

您需要使用r-1因为Word将使用其数据集中的logging编号，并且由于数据从第2行开始，并且计数器r与该行相关，所以需要r-1 。

你不需要每次打开word，所以把所有的代码设置为邮件合并的数据源，并在主循环之外创buildword doc。

 Const WTempName = "letter.docx" 'This is the 07/10 Word Templates name, Dim NewFileName As String ' Setup directories cDir = ActiveWorkbook.path + "\" 'Change if appropriate ThisFileName = ThisWorkbook.Name On Error Resume Next ' Create a Word Application instance bCreatedWordInstance = False Set objWord = GetObject(, "Word.Application") If objWord Is Nothing Then Err.Clear Set objWord = CreateObject("Word.Application") bCreatedWordInstance = True End If If objWord Is Nothing Then MsgBox "Could not start Word" Err.Clear On Error GoTo 0 Exit Sub End If ' Let Word trap the errors On Error GoTo 0 ' Set to True if you want to see the Word Doc flash past during construction objWord.Visible = False 'Open Word Template Set objMMMD = objWord.Documents.Open(cDir + WTempName) objMMMD.Activate 'Merge the data With objMMMD .MailMerge.OpenDataSource Name:=cDir + ThisFileName, _ sqlstatement:="SELECT * FROM `Data$`" ' Set this as required For r = 2 To lastrow If Cells(r, 7).Value = "Letter Generated Already" Then GoTo nextrow 'rest of code goes here 

此外，而不是检查员工名称的Excel文件来创build文件名，您可以在合并文档后执行此操作。 对我来说，这是一个更直观的链接文件名称，你刚刚合并的信。 要做到这一点更进一步行：

 With .DataSource .FirstRecord = r-1 .LastRecord = r-1 .ActiveRecord = r-1 EmployeeName = .EmployeeName 'Assuming this is the field name 

然后在保存文件之前，你可以这样做：

  ' Save new file NewFileName = "Offer Letter - " & EmployeeName & ".docx" objWord.ActiveDocument.SaveAs cDir + NewFileName 

希望这可以帮助。