See
http://www.rondebruin.nl/mail/tips2.htm

Are your mail addresses also in the table ?


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Ozbobeee" wrote in message ...
Hi All,

Background:
One base workbook creates separate workbooks with appropriate data
for each team, then displays each of the teams emails (12) ready to
send. At this stage I manually include people to cc the email to (this
varies between the 12 emails) then send.

Outcome:
I would like to automate this process if I could.

Detail:
I have the following email code (thanks to Ron DeBruin) in the base
workbook, but would like to add one or more cc's to it as well.

Not sure if this is possible but would appreciate any assistance
please?

Regards

Bob


Sub Send_Files2()

' Loops through email addresses, attaches appropriate TL file to new
email, then sends.
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range


Sheets("Sheet15").Select
Sheets("Sheet15").Select
Columns("C:C").Select
Selection.ClearContents
Columns("G:G").Select
Selection.Copy
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

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


Set sh = Sheets("Sheet15")



Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon



For Each cell In
sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants)



'Enter the file names in the C:Z column in each row if
multiple files to attach
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")



If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) 0 Then
Set OutMail = OutApp.CreateItem(0)



With OutMail
.To = cell.Value
.Subject = "Subject - " & cell.Offset(0, 4).Value
.Body = " Hi " & cell.Offset(0, 3).Value & "," &
vbNewLine & vbNewLine & _
" The attached file details your team's
statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _
" Regards,"

For Each FileCell In
rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) < "" Then
If Dir(FileCell.Value) < "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

.Display 'Or use Send
'.Send
End With



Set OutMail = Nothing
End If
Next cell



Set OutApp = Nothing


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

Sheets("Main").Select
End Sub