Is it possible to have the subject line include the names of those worksheets that were deemed true by the If statements? Would be very helpful. I can't seem to figure it out. Would like it to automatically change and list the worksheets that prompted the email. This code works perfectly for me, except for that one "bug" i'm having. I tried putting & shtsRotation after the typed subject line, but it was kind of omitted when the code was ran.
Sub Main()
Dim sh As Worksheet, i As Long, shtsRotations As String
Dim shtsFunctions As String, shtsOK As String
For Each sh In ActiveWorkbook.Worksheets
If Application.CountIf(sh.Range("L3:L70"), "<1") > 0 Then
shtsRotations = shtsRotations & vbLf & sh.Name
Else
shtsOK = shtsOK & vbLf & sh.Name & " (Rotations)"
End If
If Application.CountIf(sh.Range("M3:M70"), "<1") > 0 Then
shtsFunctions = shtsFunctions & vbLf & sh.Name
Else
shtsOK = shtsOK & vbLf & sh.Name & " (Functions)"
End If
Next sh
If Len(shtsRotations) > 0 Then
SendReminderMail "test@test.com", "Equipment rotations are due!" & shtsRotations, _
"Hello Team, " & vbNewLine & vbNewLine & _
"Check customer sheets: " & shtsRotations & vbLf & vbNewLine & _
"In the attatched workbook, you will see which equipment needs to be rotated by the red dates of their last rotation."
End If
If Len(shtsFunctions) > 0 Then
SendReminderMail "test@test.com", "Equipment functions are due! ", _
"Hello Team, " & vbNewLine & vbNewLine & _
"Check customer sheets: " & shtsFunctions & vbLf & vbNewLine & _
"In the attatched workbook, you will see which equipment needs to be functioned by the red dates, indicating their last function."
End If
If Len(shtsOK) > 0 Then
MsgBox "These sheets are OK: " & vbLf & shtsOK, vbInformation
End If
End Sub
Sub SendReminderMail(sTo As String, sSubject As String, sBody As String)
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sh As Worksheet
Dim TempFilePath As String, TempFileName As String
Dim FileExtStr As String, OutApp As Object, OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sTo
.CC = ""
.BCC = ""
.Subject = sSubject
.Body = sBody
.Attachments.Add wb2.FullName
.Display
End With
On Error GoTo 0
wb2.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your Automated Email was successfully ran at " & TimeValue(Now), vbInformation
End Sub
Aucun commentaire:
Enregistrer un commentaire