Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, i As Long, lRow As Long, rName As Range
lRow = Cells(Rows.Count, "A").End(xlUp).Row
With Sheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("E2:E" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("F2:F" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:J" & lRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
v = Range("A2:A" & lRow).Resize(, 11).Value
Set OutApp = CreateObject("Outlook.Application")
With CreateObject("scripting.dictionary")
For i = LBound(v) To UBound(v)
If v(i, 11) <> "yes" Then
Set rName = Sheets("Email Links").Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not rName Is Nothing Then
If Not .exists(v(i, 1)) Then
.Add v(i, 1), Nothing
Range("A1").CurrentRegion.AutoFilter 1, v(i, 1)
Set rng = Range("A1:G" & lRow).SpecialCells(xlCellTypeVisible)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = rName.Offset(, 21)
.cc = rName.Offset(, 22)
.Subject = "Weekly Work Issue" & "-" & v(i, 5) & "-" & v(i, 1)
.HTMLBody = "<p>Hi " & v(i, 1) & "," & "<br><br>" & "Please see below an overview of your work Tuesday to Friday. Your final schedule will be emailed to you the day before the appointments are due to take place." & "<br><br>" & v(i, 10) & "<br>" & RangetoHTML(rng)
.Display
End With
End If
Else
If MsgBox(v(i, 1) & " was not found. Do you wish to continue?", vbYesNo) = vbNo Then
Range("A1").AutoFilter
Exit Sub
End If
End If
End If
Next i
End With
Range("A1").AutoFilter
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
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"
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
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
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=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function