I am new to vba and struggling with trying to accomplish having a single overall email send out if any worksheet column L/M have a value below 1 and want it to call out which sheet (or sheets) had the value <1 in the email body or subject line. I have spent countless hours searching the web, but nothing so far has really worked for me. The MsgBox function is working fine, just having issues with compiling the results to 1 email naming which worksheet had the <1 value and 1 "solution" for the whole workbook, instead of having an email sent for every single worksheet that the conditions fit. Thank you in advance.
Option Explicit
Sub Main()
Dim sh As Worksheet, i As Long
For Each sh In ActiveWorkbook.Worksheets
With WorksheetFunction
If .CountIf(sh.Range("L3:L26"), "<1") > 0 Then
Call SendReminderMail1
Else
MsgBox "Rotations NOT needed for """ & sh.Name & """."
End If
If .CountIf(sh.Range("M3:M20"), "<1") > 0 Then
Call SendReminderMail2
Else
MsgBox "Functions are NOT needed for """ & sh.Name & """."
End If
End With
Next
End Sub
Sub SendReminderMail1()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sh As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim 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 = "test@test.com"
.CC = ""
.BCC = ""
.Subject = "Rotations are due for """ & sh.Name & """."
.Body = "Hi there bud, ya need to take a good ole look at this here document. You've been slackin', let's fix that."
.Attachments.Add wb2.FullName
.Display 'or use .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 for Rotations was successfully ran at " & TimeValue(Now), vbInformation
End Sub
Sub SendReminderMail2()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sh As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim 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 = "test@test.com"
.CC = ""
.BCC = ""
.Subject = "Functions are due for """ & sh.Name & """."""
.Body = "Hi there bud, ya need to take a good ole look at this here document."
.Attachments.Add wb2.FullName
.Display 'or use .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 for Functions was successfully ran at " & TimeValue(Now), vbInformation
End Sub
Aucun commentaire:
Enregistrer un commentaire