Hi there

I am in the process of writing a macro that splits data on a spreadsheet, copies it into a new sheet, and then emails the new sheet to the relevant person before deleting the data.

I have written the below code and the macro appears to work fine, the only problem being that no emails are actually being sent from my Outlook account. I am receiving the message stating that ' a program is trying to send email on your behalf', which indicates that it is trying to send the mail, and I select 'yes', but no mail is actually going out. i have nothing in my sent items and as i am testing the system I have put my own email address in there and I am not receiving any either.

Can anyone help point me in the right direction? I'm not suer where I have gone wrong!

thanks!


Sub SendActiveWorkbook()

Dim sname As String, i As Integer
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String
Dim BodyText As String


Workbooks.Open Filename:= _
"C:\Documents and Settings\5ERINRED\Desktop\PMS Renewal Oct.xls"

For i = 1 To 3
sname = Choose(i, "ACK", "ACO", "ADB")
On Error Resume Next

Windows("October1.xls").Activate
Selection.AutoFilter Field:=3, Criteria1:=sname
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("PMS Renewal Oct.xls").Activate
ActiveSheet.Paste
Range("E1").Activate
[E2].End(xlDown).Offset(1, 0) = "=Sum(E2:E" & [E2].End(xlDown).Row & ")"
Columns("E").Select
Selection.NumberFormat = "$#,##0"
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With OutMail
.To = Application.VLookup(Range(sname), Sheets("Adviser Names").Range("B4:F6"), 5, False)
.CC = ""
.BCC = ""
.Subject = "PMS Renewal October"
.Body = "Dear" & Application.VLookup(Range(sname), Sheets("Adviser Names").Range("B46"), 3, False) & vbCr & vbCr & _
"Please find attached your PMS Renewal Stats for October." & vbCr & vbCr & "Thanks," & vbCr & vbCr & "Beks"
.Attachments.Add ActiveWorkbook
.Send
End With

Cells.Select
Selection.ClearContents
Windows("October1.xls").Activate
Next i
End Sub