从下表中我想：
1-按列B筛选唯一值
2-一旦过滤；1〃；行，然后将该行上的每个单元格放入一个变量中
3-过滤后，如果结果超过1条记录，即同一电子邮件地址有两条或多条记录，则获取从A到E的所有范围(从范围到HTML(
4-将信息粘贴到电子邮件中
5-循环，直到B列碰到一个空白单元格，这意味着它结束了。
Table Example:
Record ID Email Data Data Data
Record1 test1@test.com 1 1 1
Record2 test2@test.com 2 2 2
Record3 test1@test.com 3 3 3
应发送或显示以下电子邮件：
1-一封包含两行的电子邮件，所有列从A到Etest1@test.com在Html的范围内
2-一封电子邮件，其中一行包含从A到E的所有列test2@test.com在变量中，然后将它们粘贴到HTML中。
'*** You must have a Outlook email configured in outlook application on your system ***
'*** add reference to outook object library from references in tools ***
Sub BulkMail()
Application.ScreenUpdating = False
Dim WB As String
Dim WB1 As String
Dim WS As Worksheet
Dim Path As String
Dim LastRow As Long
Dim LastRow1 As Long
Dim ALastRow As Long
Dim lRow As Long
Dim lCol As Long
WB = CreateObject("WScript.Shell").specialfolders("Desktop")
WB1 = "CCE Allocation Email SourceEmail Source file.xlsx"
Path = WB & "" & WB1
Workbooks.Open Filename:=Path
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, subj, atchmnt, msg, ccTo, bccTo As String
Dim name As String
Dim lstRow As Long
'My data is on sheet "Exceltip.com" you can have any sheet name.
Set WS = ActiveWorkbook.Sheets("Sheet1")
With WS
'Getting last row of containing email id in column 3.
lstRow = Cells(Rows.Count, 3).End(xlUp).Row
'Variable to hold all email ids
Dim rng As Range
Set rng = Range("A1:H" & lstRow)
Dim rng1 As Range
Set rng1 = Range("H2:H" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
'On Error GoTo cleanup 'to handle any error during creation of object.
'Loop to iterate through each row, hold data in of email in variables and send
'mail to each email id.
For Each cell In rng1
sendTo = Range(cell.Address).Offset(0, 0).Value2
name = Split(cell, ".")(0)
strHtml = "<html>" & "<body>" & "Hi " & name & ", <br><br> Here is the information to report your time in PSA for the week of March 21 to March 25, 2022" & "<br>" & "</br>" & "</body>" & "</html>"
strHtml1 = "<html>" & "<body>" & "<font face='Arial'> <p style=font-size:10pt>" & "<br><br><b>Thanks & Regards</font><br><br> " & " <font face='Cambria' color='blue'> <style=font-size:11pt><i>Padmini Chandrashekar</i></b><br></font>" & _
"<font face='Arial'><style=font-size:10pt><b>PCO,CMU</b></font><br><font face='Calibri' color='blue'><font style=font-size:10pt>ITIL-V4 Foundation Certified<br></font></font><font face='Arial'><font style=font-size:8pt>India Global Delivery Center|<font color='red'>CGI</font><br>E-City Tower II , Electronic City Phase 1,<br>Bangalore, India - 560100.<br>|<font color='blue'>M-9739012740</font>|</font><br><br><font color='red'><b>Vacation Alert : Nil</b></font></p>" & "</body>" & "</html>"
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.cc = ""
.Subject = "PSA for the week of March 18 to March 21"
.HTMLBody = strHtml & RangetoHTML(Union(rng.Rows(1), Application.Intersect(rng, cell.EntireRow))) & strHtml1
'.Attachments.Add atchmnt
'.Send 'this send mail without any notification. If you want see mail
.Display
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
唯一的电子邮件地址保存到字典中。
为每个字典条目过滤一次数据，然后将可见数据传递给RangetoHTML。
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub BulkMail()
'Application.ScreenUpdating = False
Dim wBPathRoot As String
Dim wB1 As String
Dim Path As String
Dim wbDataSource As Workbook
Dim wS As Worksheet
Dim LastRow As Long
Dim emailAddress As String
Dim objDictionary As Object
Dim arrKey As Variant
' To store unique email addresses
Set objDictionary = CreateObject("Scripting.Dictionary")
wBPathRoot = CreateObject("WScript.Shell").specialfolders("Desktop")
Debug.Print wBPathRoot
WB1 = "CCE Allocation Email SourceEmail Source file.xlsx"
Path = wBPathRoot & "" & wB1
Debug.Print Path
Set wbDataSource = Workbooks.Open(Filename:=Path)
' Early binding requires reference to Microsoft Outlook XX.X Object Library
' Application and MailItem Objects of Outlook
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
' Variables to hold values of different items of mail
Dim sendTo As String
Dim subj As String
Dim strHtml As String
Set OutApp = New Outlook.Application
Set wS = wbDataSource.Sheets("Sheet1")
With wS
'Getting last row containing emailAddress in column 2.
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
Debug.Print "LastRow: " & LastRow
Dim i As Long
For i = 2 To LastRow
Debug.Print "B" & i
emailAddress = .Range("B" & i)
Debug.Print " emailAddress: " & emailAddress
If Not objDictionary.Exists(emailAddress) Then
objDictionary.Add emailAddress, True
Debug.Print " Added: " & emailAddress
End If
Next
End With
arrKey = objDictionary.Keys
'For i = LBound(arrKey) To UBound(arrKey)
' Debug.Print " Key " & i & " - " & arrKey(i)
'Next
For i = LBound(arrKey) To UBound(arrKey)
Debug.Print " Key " & i & " - " & arrKey(i)
emailAddress = arrKey(i)
Set OutMail = OutApp.CreateItem(olMailItem)
With wS
wS.Range("A1:E" & LastRow).AutoFilter 2, "=" & emailAddress
Dim visRange As Range
Set visRange = wS.Range("A1:E" & LastRow).Rows.SpecialCells(xlCellTypeVisible)
sendTo = emailAddress
'Writing and sending new mail
With OutMail
.To = sendTo
.Subject = "PSA for the week of March 18 to March 21"
strHtml = "<html>" & "<body>" & "Hi " & "</body>"
.HTMLBody = strHtml & RangetoHTML(visRange)
.Display
End With
Set OutMail = Nothing 'nullifying OutMail object for next mail
End With
Next
cleanup:
'freeing objects created
Set OutApp = Nothing
If wS.AutoFilterMode Then wS.ShowAllData
Application.ScreenUpdating = True
Debug.Print "Done"
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function