在Excel VBA中自动化邮件合并 – 不发送多个电子邮件

这是一个自动邮件合并,我从几个不同的网站拼凑在一起。

它已被多次更改,以确保发送的电子邮件是HTML并包含默认用户签名。

点击button后,popup一个窗口select一个范围,电子邮件然后根据范围select个性化。

Sub EmailAttachmentRecipients() 'updateby Extendoffice 20160506 Dim xOutlook As Object Dim xMailItem As Object Dim xRg As Range Dim xCell As Range Dim xTxt As String Dim Signature As String Dim xEmail As String Dim xSubj As String Dim xMsg As String Dim i As Integer Dim k As Double ' Create window to select range xTxt = ActiveWindow.RangeSelection.address Set xRg = Application.InputBox("Please select the arresses list:", "Water Corporation Mail Merge", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub For i = 1 To xRg.rows.Count Set xOutlook = CreateObject("Outlook.Application") Set xMailItem = xOutlook.CreateItem(0) xMsg = "<BODY style=font-size:11pt;font-family:Verdana>" & Sheet2.Cells(4, 2) & " " & xRg.Cells(i, 1) & ",</BODY>" & "<br>" xMsg = xMsg & "" & Sheet2.Cells(6, 2) & " " & Sheet2.Cells(6, 4) & " " & Sheet2.Cells(6, 6) & " " & "<br>" & "<br>" xMsg = xMsg & "" & Sheet2.Cells(8, 2) & " " & "<br>" & "<br>" xMsg = xMsg & "" & Sheet2.Cells(10, 2) & "" & "<br>" xEmail = xRg.Cells(i, 2) With xMailItem .Display .To = xEmail .CC = "" .Subject = "" & Sheet2.Cells(2, 2) & " " & xRg.Cells(i, 3) & " - " & xRg.Cells(i, 4) & "" .HTMLBody = xMsg & .HTMLBody .Send End With Set xOutlook = Nothing Set xMailItem = Nothing Next i End Sub 

我无法让代码发送多个电子邮件,例如select5行的范围,电子邮件客户端只发送一封电子邮件。

有没有人有任何方向可以借出?

谢谢大家解决这个问题!

它看起来好像你不把循环中的撰写电子邮件。

 For i = 1 To xRg.rows.Count <<put email composing code here>> Next I