Autoemail multi email addy

[stacyg]

Ok, I have this code I am trying to change a little and I can't get it to work the way I want it to. I need to send the email to the email address listed in cell A1 for each sheet and that works perfect. However I have 30 different sheets and they are split up by 3 buyers who I need to copy. I can add one email or an alias to the CC or BCC and that works, but I really want to enter the particular buyer email into cell A2 and have it CC them. Can someone assist with this please? I tried to make the range ("A1", "A2") but no dice so I am sure my syntax is wrong. Also tried adding another condition to include A2 but nothing worked.

Sub Mail_Every_Worksheet()
'Working in Excel 2000-2013
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


TempFilePath = Environ$("temp") & "\"


If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsm": FileFormatNum = 52
End If


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


Set OutApp = CreateObject("Outlook.Application")


For Each sh In ThisWorkbook.Worksheets
If sh.Range("A1").Value Like "?*@?*.?*" Then


sh.Copy
Set wb = ActiveWorkbook


TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


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 = "Vendor Scorecard"
.Body = "Please review"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send '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
End Sub

 

[HotRhodium]

Shure have you tried something like this

With OutMail
 .to = sh.Range("A1").Value
 .CC = sh.Range("A2").Value
 .BCC = ""
 .Subject = "Vendor Scorecard"
 .Body = "Please review"
 .Attachments.Add wb.FullName
 'You can add other files also like this
 '.Attachments.Add ("C:\test.txt")
 .Send 'or use .Display
 End With

Or if you want it to send it to them both not copy the next person

With OutMail
 .to = sh.Range("A1").Value & ";" & sh.Range("A2").Value
 .CC = ""
 .BCC = ""
 .Subject = "Vendor Scorecard"
 .Body = "Please review"
 .Attachments.Add wb.FullName
 'You can add other files also like this
 '.Attachments.Add ("C:\test.txt")
 .Send 'or use .Display
 End With

Is the semicolon missing between the two recipients?

 

[HotRhodium]

I should clarify if you have each email address in a separate cell separate with & ";" & if they are in one cell they should be separated already in the cell

 

[stacyg]

Yes, I tried the 1st option but it did not work. However, I used the same email address (mine) for both. I was expecting to see two emails and only got one. I am guessing that should not matter.

 

[stacyg]

Let me try that separation, that is likely my syntax issue with trying to put them both in A1.

 

[stacyg]

so I have A1 as follows. Using my email twice for testing. Now nothing sends. I was also trying to set up a main sheet that I could vlookup the reults into A1 and A2 for ease of updating.

Tried this in A1 and nothing.

stacyg@spectralogic.com & ";" & stacyg@spectralogic.com

Option1 did not work, also tried option 2 and nothing. Note, the range is ("A1") at the top and says nothing about A2, does that need to change for it to find A2 as the range below (where to, CC and BCC are?)

I did try to enter ("A1, "A2") and that did not help with the A2 range in CC either.

 

[HotRhodium]

Ok so the & symbol here is just for combining to strings together. Outlook would like multiple email addresses to look like this when it gets it

stacyg@spectralogic.com;stacyg@spectralogic.com

This tells outlook to send it to both people to get this into a string you need something that looks like this

Cell1 & ";" & Cell2

But you have a logical evaluation here to tell if the email address is valid

If sh.Range("A1").Value Like "?*@?*.?*" Then

This test does not happen for cells a2 and a3 so lets try to assemble the string and add the next cell to the string only after it passes the same test. Also I do not know if outlook has any way to check for duplicate emails so lets test it to see if the string is being made correctly by displaying the email and checking it. this code should look like this

Sub Mail_Every_Worksheet()
 'Working in Excel 2000-2013
 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
 
 Dim MailList As String ''''''''''''''New!!!
 
 TempFilePath = Environ$("temp") & "\"
 If Val(Application.Version) < 12 Then
 'You use Excel 97-2003
 FileExtStr = ".xls": FileFormatNum = -4143
 Else
 'You use Excel 2007-2013
 FileExtStr = ".xlsm": FileFormatNum = 52
 End If
 With Application
 .ScreenUpdating = False
 .EnableEvents = False
 End With
 Set OutApp = CreateObject("Outlook.Application")
 For Each sh In ThisWorkbook.Worksheets
 If sh.Range("A1").Value Like "?*@?*.?*" Then
  MailList = sh.Range("A1").Value
   If sh.Range("A2").Value Like "?*@?*.?*" Then
    MailList = MailList & ";" & sh.Range("A2").Value
   End If
   If sh.Range("A3").Value Like "?*@?*.?*" Then
    MailList = MailList & ";" & sh.Range("A3").Value
   End If
   sh.Copy
   Set wb = ActiveWorkbook
   TempFileName = "Sheet " & sh.Name & " of " _
   & ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
   Set OutMail = OutApp.CreateItem(0)
   With wb
   .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
    .to = MailList 'sh.Range("A1").Value'Changed
    .CC = ""
    .BCC = ""
    .Subject = "Vendor Scorecard"
    .Body = "Please review"
    .Attachments.Add wb.FullName
    'You can add other files also like this
    '.Attachments.Add ("C:\test.txt")
    .Display '.Send 'or use
    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
 End Sub

 

[HotRhodium]

Now when it makes the email it will show it to you instead of sending it. For this code to work there must be a valid email address in A1 and A2 will not be added unless it to is valid, and so on for A3. From here you can check the to box of the email it should have something like

address1@example.com;address2@example.com;address3@example.com (If all three would have passes the first check on there own)

ok now I hope this works for you good luck

 

[HotRhodium]

If everything looks good the replace

.Display '.Send 'or use

With

 .Send '.Display'or use

to make it auto send again.