lundi 28 juin 2021

Compiling condition across multiple worksheets to output 1 "solution". Also call out which worksheets(s) fit the condition

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