Hi can anyone help me with a problem I have. I want the Ron de Bruin code for emailing every sheet to be able to email multiple sheets to one person. For example, I have 150 sheets, and there will be 12 recipients. Rather than 150 emails being sent, I want each recipient to receive all their attachments in 1 email. So i'd be sending a total of 12 emails rather than 150. Is anyone able to help? Many thanks

Sub Mail_Every_Worksheet()'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    
    Application.DisplayAlerts = False
    
   For Each sh In ActiveWorkbook.Worksheets
        With sh.Range("B7:D7")
            .HorizontalAlignment = xlLeft
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
        End With
    Next sh
   
    TempFilePath = Environ$("temp") & ""
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Range("A1").Value Like "?*@?*.?*" Then
            sh.Copy
            Set wb = ActiveWorkbook
            TempFileName = "Sheet " & sh.Name
            Set OutMail = OutApp.CreateItem(0)
            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next
                With OutMail
                    .to = sh.Range("A1").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "This is the Subject line"
                    .Body = "Hi there"
                    .Attachments.Add wb.FullName
                    'You can add other files also like this
                    '.Attachments.Add ("C:\test.txt")
                    .display   'or use .Display
                End With
                On Error GoTo 0
                .Close savechanges:=False
            End With
            
            Set OutMail = Nothing
            Kill TempFilePath & TempFileName & FileExtStr
        End If
    Next sh
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Application.DisplayAlerts = True
End Sub