Macro to email picking up email address in one cell using lookup

Tom9o Posts 11 Registration date Monday February 18, 2013 Status Member Last seen September 15, 2013 - Feb 18, 2013 at 01:53 AM
Tom9o Posts 11 Registration date Monday February 18, 2013 Status Member Last seen September 15, 2013 - Feb 19, 2013 at 11:32 AM
Hi can anyone help me I am using the VBA below to email a results sheet to various people,the code that I have will only allow me to email to one person at a time and I would have to change the email address in the code everytime, where you see "My Email address" is where I have to put the address that I am using. What I want to do is to put a code in is section so that it picks up an email address on my results sheet in cell "V1" as I have a lookup in that cell showing the emai address.

Sub Mail_Range()
'Working in 2000-2010
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object

Set Source = Nothing
On Error Resume Next
Set Source = Range("B1:O50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, " & _
"please correct and try again.", vbOKOnly
Exit Sub
End If

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

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "Selection of " & wb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If

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

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, _
On Error Resume Next
With OutMail
.To = "My email address"
.CC = ""
.BCC = ""
.Subject = "This is Your Results"
.Body = "Hi there"
.Attachments.Add Dest.FullName
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

Hope someone can help me I have been trying everthing it is now driving me mad!!!!!!!!!!!!!!

Thanks for your help

4 responses

rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
Feb 18, 2013 at 06:26 AM
Are you sending same email to multiple people and what some thing like this

.To = "My email address, Email2, email 3"

or are you looking to send separate emails to each person