Send Email to multiple emails

[krazeydla]

GoodDay....I need some help...I have the below code which works for the most part. I use this code for about 30 different sheets. So, if the someone's email changes or someone new comes in I have to go in and change it individually. This becomes daunting after a while. What I trying to change it so that when I run the code, it will pull the email from a different worksheet that meets a certain criteria.

I can run the report that will pull all the emails. Have it go through column A and for all that meet a group (i.e. Account1) then send to the respective email at in Column B... I want to run the code below and have it pull from that list which will be within the same workbook.

The part I am having trouble with is with the ** below...please help



Sub Mail_AccountsManagement()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object


With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the ActiveSheet to a new workbook
Sheets("Accounts1").Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select

End If
End With


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Overdue Accounts " & Format(Now, "dd-mmm-yy")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "test1@mail.com; test2@mail.com; test3@mail.com"***********this is what is says currently....I want to be able to do something like= Sheets(Group POC Emails) if column A Section="Account1" send to column B Account 1 email....*************************

.Importance = 2
.CC = ""
.BCC = ""
.Subject = "Testing"
.Body = "Test"
.Attachments.Add Destwb.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


'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub