Macro to create an email from sheets BR1 to Last sheet

[Howardc1001]

I need someone to amend my VBA Code to generate an email for sheets Br1 to last sheet. My sample data has only 3 sheets to be generated in Outlook , but by live data has 20 sheets


The Subject is named "subjectText1" on sheet "Email Branches" and Body is named "Bodytext1" I need a seperate email for each sheet from "Br1" to the last sheet. The email addresses are in AA1 to AA5 on each of these sheets. The email must only be created for each sheet where the average value in Col E2:E3 does exceed 60


I get Method or data member not found


It would be appreciated if someone could kindly check and amend my code

OutlookMail.Attachments.Add AttachedSheet.FullName

 Sub GenerateEmails()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim rngEmail As Range
    Dim avgDays As Variant
    Dim Ztext As String
    Dim Zsubject As String
    Dim AttachedSheet As Worksheet
    Dim sheetCounter As Integer
    
    ' Create Outlook application
    Set OutlookApp = CreateObject("Outlook.Application")
    
    ' Initialize sheet counter
    sheetCounter = 1
    
    
    For Each ws In ThisWorkbook.Sheets
        If ws.Name >= "BR1" 
            
            ' Check average value in Col E2:E3
            On Error Resume Next
            avgDays = Application.WorksheetFunction.Average(ws.Range("E2:E3"))
            On Error GoTo 0
            
            If IsNumeric(avgDays) And avgDays > 60 Then ' Only proceed if average exceeds 60 days
                ' Get email addresses from AA1 to AA5 on the current sheet
                Set rngEmail = ws.Range("AA1:AA5")
                
                ' Set subject and body text using a more direct approach
                Zsubject = ThisWorkbook.Sheets("Email Branches").Range("SubjectText1").Value
                Ztext = ThisWorkbook.Sheets("Email Branches").Range("BodyText1").Value
                
                ' Loop through each email address and create an email
                For Each cell In rngEmail
                    If cell.Value <> "" Then ' Check if the cell is not empty
                        ' Create a new email
                        Set OutlookMail = OutlookApp.CreateItem(0)
                        
                        ' Set email properties using additional variables
                        OutlookMail.Subject = Zsubject
                        OutlookMail.Body = Ztext
                        OutlookMail.To = cell.Value
                        
                        ' Attach the current sheet with a unique name
                        ws.Copy Before:=Sheets(1)
                        Set AttachedSheet = Sheets(1)
                        AttachedSheet.Name = "AttachmentSheet" & sheetCounter
                        sheetCounter = sheetCounter + 1
                        
                        ' Attach the copied sheet to the email
                        OutlookMail.Attachments.Add AttachedSheet.FullName
                        
                        ' Display the email (you can remove or replace this line if you want to send without displaying)
                        OutlookMail.Display
                        
                        ' Release the email object
                        Set OutlookMail = Nothing
                        ' Delete the temporary copied sheet
                        Application.DisplayAlerts = False
                        AttachedSheet.Delete
                        Application.DisplayAlerts = True
                    End If
                Next cell
            End If
        End If
    Next ws
    
    ' Release the Outlook application object
    Set OutlookApp = Nothing
End Sub

[Howardc1001]

I have finally managed to amend the code and it it working 100%

 Sub GenerateEmails()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim EmailAddresses As Range
    Dim SubjectText As String
    Dim BodyText As String
    Dim AttachmentPath As String
    Dim RecipientName As String
    Dim AttachedWb As Workbook
    Dim AverageScore As Variant
    Application.DisplayAlerts = False

    ' Create or get the Outlook application
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If OutApp Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    ' Loop through sheets from "BR1" to the last sheet
    For Each ws In ThisWorkbook.Sheets
        If ws.Index >= ThisWorkbook.Sheets("BR1").Index Then
            ' Check if AA1 cell is not blank, A1 cell is not blank, and AB1 is not equal to 0
            If Not IsEmpty(ws.Range("AA1:AA2").Value) Then
                ' Check if Col E from Row 2 onwards contains only one item
                If WorksheetFunction.CountA(ws.Range("E2:E" & ws.Cells(Rows.Count, "E").End(xlUp).Row)) = 1 Then
                    ' Get the value of the single item
                    Dim SingleItemValue As Double
                    SingleItemValue = ws.Range("E2").Value

                    ' Check if the single item value exceeds 60
                    If SingleItemValue > 60 Then
                        ' Create a new Outlook mail item
                        Set OutMail = OutApp.CreateItem(0) ' 0 represents olMailItem

                        ' Get the email addresses from the current cell in Range AA1 to AA2
                        Set EmailAddresses = ws.Range("AA1:AA2")

                        ' Concatenate email addresses into a single string separated by semicolons
                        Dim ToEmails As String
                        ToEmails = Join(Application.Transpose(EmailAddresses.Value), ";")

                        RecipientName = Trim(ws.Range("Z1").Value)

                        ' Set the email subject from the "Email" sheet
                        SubjectText = ThisWorkbook.Sheets("Email Branches").Range("B1").Value

                        ' Set the email body text from the "Email" sheet
                        BodyText = ThisWorkbook.Sheets("Email Branches").Range("BodyText1").Value

                        ' Find "Regards" and "Howard" in BodyText and insert two line breaks before them
                        BodyText = Replace(BodyText, "Regards", "<br><br>Regards")
                        BodyText = Replace(BodyText, "Howard", "<br><br>Howard")

                        ' Create a new Outlook mail item
                        With OutMail
                            .To = ToEmails
                            .Subject = SubjectText
                            .HTMLBody = BodyText
                            AttachmentPath = ThisWorkbook.Path & "\Inventory Units-" & ws.Name & ".xlsx"
                            ThisWorkbook.Sheets(ws.Name).Copy
                            Set AttachedWb = ActiveWorkbook
                            AttachedWb.SaveAs AttachmentPath
                            .Attachments.Add AttachmentPath
                            AttachedWb.Close SaveChanges:=False ' Close the attached sheet without saving
                            .Display ' Display the email
                        End With
                    End If
                Else
                    ' Compute the average of Col E
                    On Error Resume Next
                    AverageScore = Application.WorksheetFunction.Average(ws.Range("E2:E" & ws.Cells(Rows.Count, "E").End(xlUp).Row))
                    On Error GoTo 0

                    ' Check if there was an error in calculating the average
                    If IsError(AverageScore) Then
                        ' Handle the error (you might want to skip or do something else)
                        Exit For
                    End If

                    ' Check if average is less than 61, skip creating email
                    If AverageScore > 60 Then
                        ' Create a new Outlook mail item
                        Set OutMail = OutApp.CreateItem(0) ' 0 represents olMailItem

                        ' Get the email addresses from the current cell in Range AA1 to AA2
                        Set EmailAddresses = ws.Range("AA1:AA2")

                        ' Concatenate email addresses into a single string separated by semicolons
                       ' Dim ToEmails As String
                        ToEmails = Join(Application.Transpose(EmailAddresses.Value), ";")

                        RecipientName = Trim(ws.Range("Z1").Value)

                        ' Set the email subject from the "Email" sheet
                        SubjectText = ThisWorkbook.Sheets("Email Branches").Range("B1").Value

                        ' Set the email body text from the "Email" sheet
                        BodyText = ThisWorkbook.Sheets("Email Branches").Range("BodyText1").Value

                        ' Find "Regards" and "Howard" in BodyText and insert two line breaks before them
                        BodyText = Replace(BodyText, "Regards", "<br><br>Regards")
                        BodyText = Replace(BodyText, "Howard", "<br><br>Howard")

                        ' Create a new Outlook mail item
                        With OutMail
                            .To = ToEmails
                            .Subject = SubjectText
                            .HTMLBody = "Hi " & RecipientName & "<br><br>" & BodyText
                            AttachmentPath = ThisWorkbook.Path & "\Inventory Units-" & ws.Name & ".xlsx"
                            ThisWorkbook.Sheets(ws.Name).Copy
                            Set AttachedWb = ActiveWorkbook
                            AttachedWb.SaveAs AttachmentPath
                            .Attachments.Add AttachmentPath
                            AttachedWb.Close SaveChanges:=False ' Close the attached sheet without saving
                            .Display ' Display the email
                        End With
                    End If
                End If
            End If
        End If
    Next ws

    ' Clean up Outlook objects
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub