在 excel vba 中过滤收件人地址并将电子邮件发送给具有 2 行或更多行的一个人
Filter on To address and send email to one person with 2 or more rows in excel vba
我想执行以下操作，从下面的 table 我想：
1 - 每列 B 筛选唯一值
2-如果只有“1”行，则过滤一次，然后将该行上的每个单元格放入一个变量中。
3-如果结果超过 1 条记录，则过滤一次，这意味着同一电子邮件地址有 2 条或更多条记录，然后获取从 A 到 E 的所有范围（范围到 HTML）。
4- 将信息粘贴到电子邮件中。
5 循环直到 B 列遇到一个空白单元格，这意味着它结束了。
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```
At the end, the following emails should be sent or display:
1- One email with 2 rows with all columns from A to E to test1@test.com in a range to Html.
2- one email with 1 row with all columns from A to E to test2@test.com in variable then paste them into HTML.
Thank you so much for reading!
'*** 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 Source\Email 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 Source\Email 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
我想执行以下操作，从下面的 table 我想：
1 - 每列 B 筛选唯一值 2-如果只有“1”行，则过滤一次，然后将该行上的每个单元格放入一个变量中。 3-如果结果超过 1 条记录，则过滤一次，这意味着同一电子邮件地址有 2 条或更多条记录，然后获取从 A 到 E 的所有范围（范围到 HTML）。 4- 将信息粘贴到电子邮件中。 5 循环直到 B 列遇到一个空白单元格，这意味着它结束了。
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```
At the end, the following emails should be sent or display:
1- One email with 2 rows with all columns from A to E to test1@test.com in a range to Html.
2- one email with 1 row with all columns from A to E to test2@test.com in variable then paste them into HTML.
Thank you so much for reading!
'*** 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 Source\Email 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 Source\Email 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