lundi 28 juin 2021

Can you have an email subject line vary depending on results of an If Len statement?

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