I have a file where the names of about 500 employees come up that have not taken a course. I have a total of 10 columns in the file with the information needed to send the employees reminders of the courses that need to be completed.
Basically in column "B" we have the names of the employees and in column "I" the employees manager. There may be 5 employees who report to the same manager but only one email should be sent to that manager. So we filter column "I" and send the list of names that come up per manager but only send columns "A & B" in the email to each manager. i have a column with a yes which is column J and would not like to use it anymore either.
My problem is when I run the macro wont do anything at all. Any ideas what I may be doing wrong? I also added the Option Explicit at the top and still get nothing?
Any help will be greatly appreciated...
Basically in column "B" we have the names of the employees and in column "I" the employees manager. There may be 5 employees who report to the same manager but only one email should be sent to that manager. So we filter column "I" and send the list of names that come up per manager but only send columns "A & B" in the email to each manager. i have a column with a yes which is column J and would not like to use it anymore either.
My problem is when I run the macro wont do anything at all. Any ideas what I may be doing wrong? I also added the Option Explicit at the top and still get nothing?
Any help will be greatly appreciated...
Code:
Sub Audio_Macro()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim Ash As Worksheet
Dim StrBody As String
Set Ash = ActiveSheet
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each cell In Ash.Columns("I").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" _
And LCase(cell.Offset(0, 1).Value) = "Yes" Then
Ash.Range("A1:H200").AutoFilter Field:=9, Criteria1:=cell.Value
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
StrBody = "Bom dia, " & cell.Offset(, -1) & "<br>" & "<br>" & _
"Por gentileza encaminhar." & "<br>" & "<br>" & _
"Caso necessário resposta, envie a mensagem somente para Mickey Mouse." & "<br>" & "<br>" & _
"Att," & "<br><br>"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Convocação"
.HTMLBody = StrBody & RangetoHTML(rng)
.Display
'.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Ash.AutoFilterMode = False
End If
Next cell
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
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