Sub Send_Mail_autofilter()
Dim MailBody As Range
Dim dwn As Range
ActiveSheet.AutoFilterMode = False
Set mWs = Worksheets("Sheet4") '<--------------correct sheet?
'If MailBody sheet already exists then delete it
If WorksheetExists("MailBody") Then
Application.DisplayAlerts = False
Worksheets("MailBody").Delete
Application.DisplayAlerts = True
End If
'Add a sheet to copy all same address rows to
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "MailBody"
'Copy the header and the second blank row as border format will be needed for row 2
mWs.Rows(1).Copy Destination:=Worksheets("MailBody").Range("A1")
mWs.Rows(2).Copy Destination:=Worksheets("MailBody").Range("A2")
'Return to the mail content sheet
mWs.Activate
'Set email address as range for first loop to run down
Set rng = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
lastRow = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
Range("A2:C" & lastRow).Select
i = rng.Rows.Count
For Each cell In rng
If cell.Value <> "" Then
If Not cell.Offset(0, 1).Value = "yes" Then
Range("A1:C8").Select
Selection.AutoFilter Field:=3, Criteria1:=cell.Value
With ActiveSheet.AutoFilter.Range.Offset(1, 0)
.Copy Sheets("MailBody").Range("A3")
End With
'Need to add yes to each autofiltered row
For Each dwn In rng.SpecialCells(xlCellTypeVisible)
rng.Offset(0, 1).Value = "yes"
Next
'Turn off autofilter
ActiveSheet.AutoFilterMode = False
'Mail header parameters
MailTo = cell.Value 'column E
MailSubject = "Subject?" '<------------------------Subject
'Autofit the copied rows on the new sheet
With Worksheets("MailBody")
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set MailBody = .Range(.Cells(1, 1), .Cells(lRow, 3))
.Range("A1:C2").Columns.AutoFit
End With
'Add mail intro
MsgStr = "Hi " & cell.Offset(0, -2).Value _
& "<br><br> Please see below confirmed stock:"
'Create mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = MailTo
.CC = mailcc
.Subject = MailSubject
.HTMLBody = MsgStr & RangetoHTML(MailBody)
.Display
'send
End With
cell.Offset(0, 1).Value = "yes"
'Clear the MailBody rows up to the header
With Worksheets("MailBody")
.Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With
End If
End If
MailTo = ""
MailSubject = ""
Next
'Clear 'yes' from column D
Range("D2:D" & i + 1).ClearContents
'Delete MailBody sheet
Application.DisplayAlerts = False
Worksheets("MailBody").Delete
Application.DisplayAlerts = True
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 -4163, , False, False
.Cells(1).PasteSpecial -4122, , 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:=4, _
filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=0)
.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
'Does the worksheet exists
Function WorksheetExists(WSName) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
