I have a macro that sends emails with attachments based on the customer name. My problem is when I want to send an email with multiple people in the "To:" box it won't send. For example I would want the email sent to "[email protected]" and "[email protected]" so in my recipients column I have "[email protected]; "[email protected]"[/email]". Outlook then pops up saying it doesn't recognize "[email protected]; "[email protected]"[/email]" as it it were one single email. Anyone got any ideas why? Below is my code
Code
Sub EmailMacro()
Dim OutApp As Object
Dim fLoc As String
Dim cell As Range, rng As Range
Dim vFile As Variant, vFiles As Variant
Dim Lastrow As Integer
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("I2:L" & Lastrow).ClearContents
'Range of cells with recipeant info
'Column A is attaachment filenames (multiple filenames separated by ; e.g File1.xls;File2.xls
'Column B is the email address - can be seperated by ;
'Column C is the CC Email Address
'Column D is the File path for the attachment files
'Column E is the Status to determine if it gets emailed or not
'Column F is the Email Subject
'Column G is the Email Body
'Column H is the customer name
With ThisWorkbook.ActiveSheet
Set rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With
Set OutApp = CreateObject("Outlook.Application")
' Read in the data and create a new message with attachment for each Excel entry
For Each cell In rng
'Sends Clients Email
If cell.Offset(, 4).Value = "Email" Then
'File path in column C
fLoc = cell.Offset(, 3).Value
If Right(fLoc, 1) <> "\" Then fLoc = fLoc & "\"
'Create a new Email for each recpient
With OutApp.CreateItem(0)
'Recipient
.Recipients.Add cell.Offset(, 1).Value
.CC = cell.Offset(, 2).Value
.Subject = cell.Offset(, 5).Value
.body = cell.Offset(, 6).Value
'Attach each file
vFiles = Split(cell.Value, ";")
For Each vFile In vFiles
If Len(Dir(fLoc & vFile)) Then
.Attachments.Add fLoc & vFile
Else
AppActivate ThisWorkbook.Parent
MsgBox "Could not locate file: " & vbCr & fLoc & vFile, , "File Not Found"
End If
Next vFile
.Display
.Send
End With
End If
'This Part puts Mail customers into the Mail column
If cell.Offset(, 4).Value = "Mail" Then
cell.Offset(, 7).Copy
cell.Offset(, 8).PasteSpecial Paste:=xlValues
End If
'Puts Fax customers into the Fax column
If cell.Offset(, 4).Value = "Fax" Then
cell.Offset(, 7).Copy
cell.Offset(, 9).PasteSpecial Paste:=xlValues
End If
'Puts Blanks into Mistakes Column
If cell.Offset(, 4).Value = "" Then
cell.Offset(, 7).Copy
cell.Offset(, 11).PasteSpecial Paste:=xlValues
End If
'Puts Special customers into the Special Column
If cell.Offset(, 4).Value = "Special" Then
cell.Offset(, 7).Copy
cell.Offset(, 10).PasteSpecial Paste:=xlValues
End If
Next cell
'Deletes Empty cells in columns I through L in order to make it easier to read and organize
Columns("I:L").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
'Copying Clients List into Respective Sheets
'Copying The Mailed Clients onto the Sheet
Range("I2:I" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
Sheets("Mailing List").Select
Range("A2").Select
ActiveSheet.Paste
Range("B2").Select
Range("B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row)
'Copying The Fax Clients onto the Fax Sheet
Sheets("Sheet1").Select
Range("J2:J" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
Sheets("Fax List").Select
Range("A2").Select
ActiveSheet.Paste
'Copying the Special Notes onto the Special Notes Sheet
Sheets("Sheet1").Select
Range("K2:K" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
Sheets("Special Notes").Select
Range("A2").Select
ActiveSheet.Paste
End Sub