(VBA) Email excel attachments in one email rather than separately.

[Logit]

.
These macros to be pasted into a regular module :

Option Explicit


Sub CreateNewWB()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim c As Range
    Dim x As Integer
    Dim FName As String
    Dim FPath As String
    Dim NewBook As Workbook
    Dim wbPaste As Workbook
        
    Application.ScreenUpdating = False
    FPath = Environ("USERPROFILE") & "\Desktop\EmailGroup\"    'Change this line to your path
   
    For Each c In Sheet1.Range("A2:A4") '<---  edit range for all email addresses
        If c.Value <> "" Then
            Set NewBook = Workbooks.Add
            NewBook.SaveAs FPath & c.Value & ".xlsx"
        End If
    Next c
    
    For Each wb In Application.Workbooks
        If Not (wb Is Workbooks("Copy Sheet New Workbook.xlsm")) Then
            wb.Close
        End If
    Next
    
    x = 1
    
    For Each ws In Worksheets
        If ws.Name <> "Email List" Then 'You may need to change this line to reflect a different "Main" Sheet
            With ws
                For Each c In Sheet1.Range("A2:A4") '<---  edit range for all email addresses
                    Set wbPaste = Workbooks.Open(FPath & c.Value & ".xlsx")
                    If ws.Range("A1").Value = c.Value Then
                            ws.Copy After:=wbPaste.Sheets(wbPaste.Sheets.Count)
                            
                            'Workbooks(wbPaste).Activate
                            ActiveSheet.Name = ActiveSheet.Range("A1").Value & " " & x
                            ActiveWorkbook.Close True
                    End If
                     x = x + 1
                   
                Next c
                
            End With
        End If
    Next
    Application.ScreenUpdating = True
    
    For Each wb In Application.Workbooks
        If Not (wb Is Workbooks("Copy Sheet New Workbook.xlsm")) Then
            wb.Close
        End If
    Next
    
LoopAllFilesInFolder
End Sub


Sub LoopAllFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String


Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


myPath = Environ("USERPROFILE") & "\Desktop\EmailGroup\"
myExtension = "*.xls*"


myFile = Dir(myPath & myExtension)
Do While myFile <> ""
If Len(myFile) = 0 Then Exit Do
Set wb = Workbooks.Open(fileName:=myPath & myFile)
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete


wb.Close SaveChanges:=True


myFile = Dir
Loop


'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


Send_Email


End Sub


Sub Send_Email()


    Dim c As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
    
    For Each c In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
        Set OutLookApp = CreateObject("Outlook.application")
        Set OutLookMailItem = OutLookApp.CreateItem(0)
        With OutLookMailItem
                .To = c.Value
                .CC = "Your CC here"
                .BCC = "test"
                .Subject = "This is the Subject line"
                .HTMLBody = "Hi there"
                .Attachments.Add Environ("USERPROFILE") & "\Desktop\EmailGroup\" & c.Offset(i, 1).Value
                .Display
                '.Send
        End With
    Next c


End Sub

See instructions on first sheet of download file ...