.
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 ...