Sub Send_Table_2()
Dim MailBody As Range
Set mWs = Worksheets("Sheet1")
'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 person rows to
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "MailBody"
'Copy the header
mWs.Rows(1).Copy Destination:=Worksheets("MailBody").Range("A1")
'Return to the mail content sheet
mWs.Activate
'Set email address as range for first loop to run down
Set rng = Range(Range("E2"), Range("E" & Rows.Count).End(xlUp))
'Get a row count to clear column H at the end
i = rng.Rows.Count
For Each cell In rng
If cell.Value <> "" Then
If Not cell.Offset(0, 2).Value = "yes" Then
'Get the row number
cRow = cell.Row
'Copy the row to the first empty row in the MailBody sheet
mWs.Range("A" & cRow, "F" & cRow).Copy Destination:=Sheets("MailBody").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
MailTo = cell.Value 'column E
mailcc = cell.Offset(0, -3).Value
MailSubject = "Subject?"
'Second loop checks the email addresses of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the MailBody sheet
For Each dwn In rng.Offset(cRow - 1, 0)
If dwn.Value = cell.Value Then
dwn.Offset(0, 2).Value = "yes"
'Create additional table row for each extra row found
mWs.Range("A" & cRow, "F" & cRow).Copy Destination:=Sheets("MailBody").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next
'Autofit the copied rows on the new sheet, otherwise they'll be copied to the mail with defaults widths, heights
With Worksheets("MailBody")
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set MailBody = .Range(.Cells(1, 1), .Cells(lRow, 6))
.Range("A1:F2").Columns.AutoFit
End With
'Add mail intro
MsgStr = "Dear " & cell.Offset(0, 1).Value _
& "<br><br> Please see below"
'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, 2).Value = "yes"
'Clear the MailBody rows up to the header
With Worksheets("MailBody")
.Range("A2:F" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
End With
End If
End If
MailTo = ""
MailSubject = ""
Next
'Clear 'yes' from column G
Range("G2:G" & 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
