Email rows if conditions met

Although @Mumps questions are relevant and answers are needed, I have made a number of assumptions to provide a possible solution. The code needs data entry in a few places, annotated by '''''''' characters. One assumption is that you can enter emails for each contact in column I as in the attached email. Also, enter the management email in cell M2.

Sub Email_filter_todo()
'Excel Macro : Filter and Paste Unique Values to New Sheets and new Email
'This code writes to Range BB and then deletes that data
'It creates new worksheets that are then deleted As well
'It calls another code module to send summary to management
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last, i, z, lr As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "Sheet1"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:I" & last)
Sheets(sht).Range("I1:I" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True
    For Each x In Range([BB2], Cells(Rows.Count, "BB").End(xlUp))
        With rng
            .AutoFilter
            .AutoFilter Field:=9, Criteria1:=x.Value
            .AutoFilter Field:=4, Criteria1:="All Parts available"
            .AutoFilter Field:=6, Criteria1:="OUT"
            .AutoFilter Field:=5, Criteria1:="<" & Date, Operator:=xlAnd
            If .SpecialCells(xlCellTypeVisible).Count > 10 Then
                .SpecialCells(xlCellTypeVisible).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
                ActiveSheet.Paste
                ActiveSheet.Columns.AutoFit
                Columns("I").EntireColumn.Hidden = True
                'Call code below
                Send_newemail (i)
                Columns("I").EntireColumn.Hidden = False
                'Code Removes new sheet that was created
                Application.DisplayAlerts = False
                    Sheets(x.Text).Delete
                Application.DisplayAlerts = True
            End If
        End With
    Next x

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    
    ' Remove data from column BB
    Range([BB2], Cells(Rows.Count, "BB").End(xlUp)) = ""

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
    'Run code from below to send summary to management
    Call Email_to_Management
End Sub

Sub Send_newemail(i)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim lr, a, b, y As Integer
    Dim sht As String

    sht = "Sheet1"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    lr = Cells(Rows.Count, "I").End(xlUp).Row 'with cells = 3
    On Error GoTo 0
   
    With OutMail
        .To = Sheets(sht).Range("I2").Value
        .CC = "" '''''' Enter Value if needed, maybe your own email to confirm email sent
        .Subject = "Daily Customer Part Update" ' Range("C2").Value
        .HTMLBody = RangetoHTML(rng) & vbNewLine
        .Display
        '.Send ''''''Remove apostrophe in front of this line and add apostrophe to .display line to send email without seeing draft email
   End With

   Set OutMail = Nothing
   Set OutApp = Nothing
    
End Sub

Function RangetoHTML(rng As Range)
'Function Required for the code to work correctly
    Dim FSO As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

Sub Email_to_Management()

Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last, i, z, lr As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "Sheet1"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:I" & last)
        With rng
            .AutoFilter
            .AutoFilter Field:=4, Criteria1:="All Parts available"
            .AutoFilter Field:=6, Criteria1:="OUT"
            .AutoFilter Field:=5, Criteria1:="<" & Date, Operator:=xlAnd
            If .SpecialCells(xlCellTypeVisible).Count > 10 Then
                .SpecialCells(xlCellTypeVisible).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Sum"
                ActiveSheet.Paste
                ActiveSheet.Columns.AutoFit
                'Call code below
                Send_newemailM (i)
                'Code Removes new sheet that was created
                Application.DisplayAlerts = False
                    Sheets("Sum").Delete
                Application.DisplayAlerts = True
            End If
        End With

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

Sub Send_newemailM(i)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim lr, a, b, y As Integer
    Dim sht As String

    sht = "Sheet1"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    lr = Cells(Rows.Count, "I").End(xlUp).Row 'with cells = 3
    On Error GoTo 0
   
    With OutMail
        .To = Sheets(sht).Range("M2").Value 
        .CC = "" '''''' Enter Value if needed, maybe your own email to confirm email sent
        .Subject = "Daily Customer Part Update Summary"
        .HTMLBody = RangetoHTML(rng) & vbNewLine
        .Display
        '.Send '''''' Remove apostrophe in front of this line and add apostrophe to .display line to send email without seeing draft email
   End With

   Set OutMail = Nothing
   Set OutApp = Nothing
    
End Sub

That's fantastic, thank you

There's one issue though, when you click 'send email' it filters them correctly but wants to send each email to 'grthomas'
The managers button though, works perfectly

Yes, a button that basically filters column B to show only 'C' and then email the full sheet regardless of parts delivered or OUT etc.

Sorry if I am being a pest, I am very new to using this function

Got the commercial vehicle bit working now, I just added another button and copied your code into another macro with different filters.

Only issue remaining is the advisors button sending all the emails to the same person

Repaired the first two modules.

Sub Email_filter_todo()
'Excel Macro : Filter and Paste Unique Values to New Sheets and new Email
'This code writes to Range BB and then deletes that data
'It creates new worksheets that are then deleted As well
'It calls another code module to send summary to management
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last, i, z, lr As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "Sheet1"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:I" & last)
Sheets(sht).Range("I1:I" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True
i = 1
    For Each x In Range([BB2], Cells(Rows.Count, "BB").End(xlUp))
    i = i + 1
        If x.Value = "" Then GoTo skip
        With rng
            .AutoFilter
            .AutoFilter Field:=9, Criteria1:=x.Value
            .AutoFilter Field:=4, Criteria1:="All Parts available"
            .AutoFilter Field:=6, Criteria1:="OUT"
            .AutoFilter Field:=5, Criteria1:="<" & Date, Operator:=xlAnd
            If .SpecialCells(xlCellTypeVisible).Count > 10 Then
                .SpecialCells(xlCellTypeVisible).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(x.Value, 4)
                Sheets(Left(x.Text, 4)).Paste
                Sheets(Left(x.Text, 4)).Columns.AutoFit
                Sheets(Left(x.Text, 4)).Columns("I").EntireColumn.Hidden = True
                'Call code below
                Send_newemail (i)
                'Columns("I").EntireColumn.Hidden = False
                'Code Removes new sheet that was created
                Application.DisplayAlerts = False
                    Sheets(Left(x.Text, 4)).Delete
                Application.DisplayAlerts = True
            End If
        End With
skip:
    Next x

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    
    ' Remove data from column BB
    Range([BB2], Cells(Rows.Count, "BB").End(xlUp)) = ""

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub

Sub Send_newemail(i)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim lr, a, b, y As Integer
    Dim sht As String

    sht = "Sheet1"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    lr = Cells(Rows.Count, "I").End(xlUp).Row 'with cells = 3
    On Error GoTo 0
   
    With OutMail
        .To = Sheets(sht).Cells(i, "I").Value
        .CC = "" '''''' Enter Value if needed, maybe your own email to confirm email sent
        .Subject = "Daily Customer Part Update" ' Range("C2").Value
        .HTMLBody = RangetoHTML(rng) & vbNewLine
        .Display
        '.Send ''''''Remove apostrophe in front of this line and add apostrophe to .display line to send email without seeing draft email
   End With

   Set OutMail = Nothing
   Set OutApp = Nothing
    
End Sub

Thank you,
Now the grthomas and sajeesh.s emails are working fine, but the next one tries to send the sheet for jaffar.taher to hamza and the remaining sheets don't have a recipient

I tried changing the range from "BB" to "I" but it tried to send 300 seperate emails

my bad, I was overthinking the process. This correction should resolve the issue;

Sub Email_filter_todo()
'Excel Macro : Filter and Paste Unique Values to New Sheets and new Email
'This code writes to Range BB and then deletes that data
'It creates new worksheets that are then deleted As well
'It calls another code module to send summary to management
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last, i, z, lr As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "Sheet1"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:I" & last)
Sheets(sht).Range("I1:I" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True
i = 1
    For Each x In Range([BB2], Cells(Rows.Count, "BB").End(xlUp))
    i = i + 1
        If x.Value = "" Then GoTo skip
        With rng
            .AutoFilter
            .AutoFilter Field:=9, Criteria1:=x.Value
            .AutoFilter Field:=4, Criteria1:="All Parts available"
            .AutoFilter Field:=6, Criteria1:="OUT"
            .AutoFilter Field:=5, Criteria1:="<" & Date, Operator:=xlAnd
            If .SpecialCells(xlCellTypeVisible).Count > 10 Then
                .SpecialCells(xlCellTypeVisible).Copy
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(x.Value, 4)
                Sheets(Left(x.Text, 4)).Paste
                Sheets(Left(x.Text, 4)).Columns.AutoFit
                Sheets(Left(x.Text, 4)).Columns("I").EntireColumn.Hidden = True
                'Call code below
                Send_newemail
                'Columns("I").EntireColumn.Hidden = False
                'Code Removes new sheet that was created
                Application.DisplayAlerts = False
                    Sheets(Left(x.Text, 4)).Delete
                Application.DisplayAlerts = True
            End If
        End With
skip:
    Next x

    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    
    ' Remove data from column BB
    Range([BB2], Cells(Rows.Count, "BB").End(xlUp)) = ""

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub

Sub Send_newemail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim lr, a, b, y As Integer
    Dim sht As String

    sht = "Sheet1"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    lr = Cells(Rows.Count, "I").End(xlUp).Row 'with cells = 3
    On Error GoTo 0
   
    With OutMail
        .To = Range("I2").Value
        .CC = "" '''''' Enter Value if needed, maybe your own email to confirm email sent
        .Subject = "Daily Customer Part Update" ' Range("C2").Value
        .HTMLBody = RangetoHTML(rng) & vbNewLine
        .Display
        '.Send ''''''Remove apostrophe in front of this line and add apostrophe to .display line to send email without seeing draft email
   End With

   Set OutMail = Nothing
   Set OutApp = Nothing
    
End Sub

Perfect now, thank you for your help