I have made some code but if the range R2:34 is blank, it will still open the template email with no data in him. Please tell me where am I doing the bad connection.
Sub 1()
Dim OutApp As Object
Dim OutMail As Object
Dim sTo As String
Dim spo As String
Dim emailRng As Range, cl As Range, dtrecuta As Range
Dim c As Range
For Each cell In Cells.Range("N2:N34")
If LCase(Cells(cell.Row, "N").Value) = "0" Or LCase(Cells(cell.Row, "N").Value) < "480" Then
On Error Resume Next
Cells(cell.Row, "R").Value = Cells(cell.Row, "M").Value
Else
Cells(cell.Row, "R").Value = Null
End If
Next cell
a = CLng(Date)
Set emailRng = Worksheets("Sheet1").Range("r2:r34")
Set dtrecuta = Worksheets("Sheet1").Range("P2")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("C:\Users\Marius\AppData\Roaming\Microsoft\Templates\statistica.oft")
On Error Resume Next
With OutMail
.To = sTo
.CC = ""
.BCC = ""
.Subject = "TESTARE Statistica pentru data de " & dtrecuta
strbody = "Buna " & " , " & vbNewLine & vbNewLine & _
"Te rog sa trimiti statistica astazi " & a & " pana in ora 10:00, " & _
" pentru data de " & dtrecuta & vbNewLine & vbNewLine & "O zi buna." & _
" " & vbNewLine & vbNewLine & " Acesta este un mesaj automat nu raspundeti la acest e-mail. "
.Display
.Body = strbody & Signature
.send
End With
On Error GoTo cleanup
Set OutMail = Nothing
cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Add an IF statement just after setting your range to check if it is all blank cells:
Set emailRng = Worksheets("Sheet1").Range("r2:r34")
If WorksheetFunction.CountBlank(emailRng) = emailRng.Cells.Count Then Exit Sub 'No data
Related
I'm attempting to send an email for each attendance event that is being displayed within the Pivot Table. Though it will recognize the count of rows, only the 1st row is being sent in email up to as many emails as there are rows of data.
I believe I need my offset parameters to change so it's changing by row & cell. Any suggestions?
enter image description here
Sub EmailBody()
Application.ScreenUpdating = False
ThisWorkbook.RefreshAll
'Tells it to re-run every x hours and min.
Application.OnTime Now + TimeValue("1:00"), "EmailBody"
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Dim arrHolidays As Variant, iDay As Variant
arrHolidays = Application.Transpose(Worksheets("Hold").Range("a:a").Value) 'Add all your holidays on Holidays worksheet
For Each iDay In arrHolidays
If Date = iDay Then Exit Sub 'exit this sub if date is a holiday
Next
On Error Resume Next
ThisWorkbook.RefreshAll
Worksheets("Sheet1").Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, MailBody As String
Dim lstRow As Long
ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id.
lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range
Set rng = Range("B2:B" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
For Each i In Range("b2:b100")
MailBody = "Please see the following attendance event logged in SharePoint for " & i.Offset(0, -1) & "." & vbCr & vbCr & "Date of Absence " & " : " & i.Offset(0, 2) & vbCr & "Reason for Absence " & " : " & i.Offset(0, 3) & vbCr & "Ticket Entered on" & " : " & i.Offset(0, 4) & vbCr & "Created By" & " : " & i.Offset(0, 5) & vbCr & "Notes" & " : " & i.Offset(0, 6) & vbCr & vbCr & "Please reach out to DLWESTCCWALKERRETENTIONREPORTING#charter.com, if you have any questions."
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2 & ";" & Range(cell.Address).Offset(0, 1).Value2
Subj = "Attendance Callout Event Notification"
Msg = MailBody
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Body = Msg
.Subject = Subj
.Display '
.Send
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Next
End Sub
I have code which sends a file via Outlook and gets-saves data into an Excel file.
For sending a file via Outlook, it works perfectly. However it saves data into the same row of the Excel file. Code should save data into the next empty row of the Excel file.
Sub AutoEmail()
On Error GoTo Cancel
Dim Resp As Integer
Resp = MsgBox(prompt:=vbCr & "Yes = Review Email" & vbCr & "No = Immediately Send" & vbCr & "Cancel = Cancel" & vbCr, _
Title:="Review email before sending?", _
Buttons:=3 + 32)
'dfsfsd
Range("S20").Copy
Range("T20").PasteSpecial xlPasteValues
'sdaasdf
Workbooks.Open ("C:\Users\computername\Desktop\New folder (2)\ff.xlsx")
ThisWorkbook.Activate
'1
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy _
Workbooks("ff.xlsx").Worksheets("Sayfa1").Range("P2")
'1
Select Case Resp
'Yes was clicked, user wants to review email first
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = Application.ActiveWorkbook.FullName
With otlNewMail
.To = Cells(33, 10)
.CC = Cells(1, 1)
.Subject = Cells(23, 10) & ": " & Cells(21, 10)
.Body = "this is a text" & vbCr & vbCr & "" & Cells(23, 10) & "."
.Attachments.Add FName
.Display
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If no is clicked
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & " " & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Send
'.Display
'Application.Wait (Now + TimeValue("0:00:01"))
'Application.SendKeys "%s"
End With
'otlApp.Quit
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If Cancel is clicked
Case Is = 2
Cancel:
MsgBox prompt:="No Email has been sent.", _
Title:="EMAIL CANCELLED", _
Buttons:=64
End Select
End Sub
How can I save data (End(xlUp).Row) into the next empty row of an Excel file?
Change:
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy _
Workbooks("ff.xlsx").Worksheets("Sayfa1").Range("P2")
To this:
With Workbooks("ff.xlsx").Worksheets("Sayfa1")
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy .Range("P" & .Range("P" & .Rows.count).End(xlUp).Row + 1)
End With
I'm new to VB in Excel.
I made an email reminder program in Excel with value changed from formula (calculation) in one of the cell.
The problem is the email reminder did not pop up even though the conditions are met.
But when I put manually the number (to meet the condition), the email reminder did pop up.
Please help to make the program run if the cell value from calculation met the condition of the program. Thanks!
Here is the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim completed As Boolean
Dim rowCount As Long
Dim i As Integer
Dim Objek As String
Dim SatKer As String
Dim Hari As String
Dim AlamatEmail As String
Dim xMailBody As String
rowCount = 2
If Target.Cells.Count > 1 Then Exit Sub
For i = 1 To 5
rowCount = rowCount + 1
Set xRg = Range("O" & CStr(rowCount))
Objek = ActiveSheet.Range("F" & CStr(rowCount)).Value
SatKer = ActiveSheet.Range("G" & CStr(rowCount)).Value
Hari = ActiveSheet.Range("O" & CStr(rowCount)).Value
AlamatEmail = ActiveSheet.Range("S" & CStr(rowCount)).Value
If xRg = Target And Target.Value < 4 Then
Call Mail_small_Text_Outlook(Objek, SatKer, Hari, AlamatEmail)
End If
Next i
End Sub
Sub Mail_small_Text_Outlook(Objek As String, SatKer As String, Hari As String, AlamatEmail As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Yth. Bapak Widi " & vbNewLine & vbNewLine & _
"Laporan Penilaian " & Objek & " milik " & SatKer & " mendekati batas akhir pengumpulan." & vbNewLine & _
"Laporan tersebut harus disubmit dalam " & Hari & " hari." & vbNewLine & vbNewLine & _
"Mohon cek status laporan penilaian untuk keterangan laporan lebih detail."
On Error Resume Next
With xOutMail
.To = AlamatEmail
.cc = ""
.BCC = ""
.Subject = "Laporan Penilaian " & Objek & " milik " & SatKer
.HTMLBody = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
The following should do what you expect, the code will loop through column O and if the value calculated is less than 4 then it will .Display the email:
Private Sub Worksheet_Calculate()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "O").End(xlUp).Row
'get the last row with data on Column O
Dim completed As Boolean
Dim rowCount As Long
Dim i As Integer
Dim Objek As String
Dim SatKer As String
Dim Hari As String
Dim AlamatEmail As String
Dim xMailBody As String
For i = 3 To LastRow 'loop from row 3 to last on Column O
Set xRg = Range("O" & i)
Objek = ws.Range("F" & i).Value
SatKer = ws.Range("G" & i).Value
Hari = ws.Range("O" & i).Value
AlamatEmail = ws.Range("S" & i).Value
If ws.Cells(i, "O").Value < 4 Then 'if value is less than 4 then send email
Call Mail_small_Text_Outlook(Objek, SatKer, Hari, AlamatEmail)
End If
Next i
End Sub
Sub Mail_small_Text_Outlook(Objek As String, SatKer As String, Hari As String, AlamatEmail As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Yth. Bapak Widi " & vbNewLine & vbNewLine & _
"Laporan Penilaian " & Objek & " milik " & SatKer & " mendekati batas akhir pengumpulan." & vbNewLine & _
"Laporan tersebut harus disubmit dalam " & Hari & " hari." & vbNewLine & vbNewLine & _
"Mohon cek status laporan penilaian untuk keterangan laporan lebih detail."
On Error Resume Next
With xOutMail
.To = AlamatEmail
.cc = ""
.BCC = ""
.Subject = "Laporan Penilaian " & Objek & " milik " & SatKer
.HTMLBody = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
I am attempting to email to all email addresses in a table, with the subject line being the corresponding order number or numbers.
The Table has Five columns - "Line Number", "Order Number", "Suppler/Manf.Item Number", "Supplier Name" and "Email Address"
There can be duplicates, but the subject must contain each PO only once.
No CC, or BCC is required
The Body of the Email is to list the PO's with their associated line items.
Hello, We require an update as to the following:
EX
PO86001763
Line Item 2
Line Item 1
Please Send an update as to the status of these line items.
Providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates.
(These being able to be edited would be a boon)
The table is made from an import and format macro, it will always be in the same format, but will contain different data. The amount of data can increase or decrease depending on the week.
Here is my attempt.
Private Sub CommandButton2_Click()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Dim I As Integer
Dim X As Integer
Dim C As Object
Dim firstaddress As Variant
Dim Nrow As Boolean
Set tb = ActiveSheet.ListObjects("Table10")
For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
emAddress = tb.DataBodyRange.Cells(I, tb.ListColumns("Email Address").Index)
For X = LBound(myArray1) To UBound(myArray1)
On Error Resume Next
If emAddress = myArray1(X) Then GoTo goToNext
Next X
On Error GoTo 0
subjectLine = "Order(s) # "
ReDim Preserve myArray1(1 To nameCounter)
myArray1(nameCounter) = emAddress
nameCounter = nameCounter + 1
lineCounter = 1
With tb.ListColumns("Email Address").Range
Set C = .Find(emAddress, LookIn:=xlValues)
If Not C Is Nothing Then
firstaddress = C.Address
Beep
arrayCounter = arrayCounter + 1
Do
Nrow = C.Row - 1
If lineCounter = 1 Then
subjectLine = subjectLine & tb.DataBodyRange.Cells (Nrow, tb.ListColumns("Order Number").Index)
lineCounter = lineCounter + 1
bodyline = "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
Else:
subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index)
bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstaddress
End If
Run SendMailFunction(emAddress, subjectLine, bodyline)
' Debug.Print vbNewLine
' Debug.Print emAddress
' Debug.Print "Subject: " & subjectLine
' Debug.Print "Body:" & vbNewLine; bodyline
End With
goToNext:
Next I
Set C = Nothing
End Sub
Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
Dim I As Integer
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table10")
For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emAddress
.Subject = subjectLine
.Body = "Hello, We require an update as to the following:" & DNL & bodyline _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Next I
End Function
The following code uses the email script as a function, which is called from the top macro. Please click on answer if this solves your problem
Sub findMethodINtable()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Set tb = ActiveSheet.ListObjects("Table14")
For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
emAddress = tb.DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
For x = LBound(myArray1) To UBound(myArray1)
On Error Resume Next
If emAddress = myArray1(x) Then GoTo goToNext
Next x
On Error GoTo 0
subjectLine = "Order(s) # "
ReDim Preserve myArray1(1 To nameCounter)
myArray1(nameCounter) = emAddress
nameCounter = nameCounter + 1
lineCounter = 1
With tb.ListColumns("Email Address").Range
Set c = .Find(emAddress, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Beep
arrayCounter = arrayCounter + 1
Do
nRow = c.Row - 1
If lineCounter = 1 Then
subjectLine = subjectLine & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
lineCounter = lineCounter + 1
bodyline = "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
Else:
subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Run SendMailFunction(emAddress, subjectLine, bodyline)
' Debug.Print vbNewLine
' Debug.Print emAddress
' Debug.Print "Subject: " & subjectLine
' Debug.Print "Body:" & vbNewLine; bodyline
End With
goToNext:
Next i
Set c = Nothing
End Sub
Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emAddress
.Subject = subjectLine
.Body = "Hello, We require an update as to the following:" & DNL & bodyline _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End Function
This works for me, given table name is "Table14"
Sub wserlkug()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")
For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
.Subject = "Order # " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Order Number").Index)
.Body = "Hello, We require an update as to the following:" & DNL & "Line #: " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Line Number").Index) _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Next i
End Sub
You can actually use the object variable "tb" instead of ActiveSheet.ListObjects("Table14").... I placed that there to show how to reference row and column in a table.
When I complete a piece of work I email it to certain people. It depends on the work who gets it.
If any person in the list leaves, changes job or has an email change the code will bug out saying
Run Time error -2147467259(80004005), Outlook Does Not Recognise One Or More Names
If I manually copy the email addresses in the list and pop them into Outlook and send I'll get an email back saying the user doesn't exist or has been changed.
I have tried On Error Resume Next and On Error Goto. I have added MS Outlook 14.0 Object Libary, SharePoint Social Provider, Social Provider Extensibility and Outlook View control from the references.
The code bugs out on the .send
Sub EMailer()
Application.ScreenUpdating = False
strfilepath = "\\DFZ70069\Data\199711009\workgroup\Res Plan Team\Performance Management\Specialised Reporting\Debit & Credit Reporting\Masters\Sent Reports\"
strArea = "Recipients" '..........................................................................................
'Get list of recipients for email
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value = "" Then GoTo Continue
strmaillist = strmaillist & cell.Value + ";"
Continue:
Next
[B1].Value = strmaillist
If bMyEmail = True Then
strmaillist = strmaillist & MyEmailAddress
End If
'Display email list
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Sending " & sReportName & " emails to " & vbNewLine & strArea, _
AckTime, "Message Box", 0)
Case 1, -1
End Select
'SEND EMAIL
'set up Body of email............
strbody = "Please find attached " & sReportName & " Report " & " _" & strDate & vbLf & vbLf & _
strComments & vbLf & _
strComments2 & vbLf & _
"" & vbLf & _
eMailName & vbLf & _
"MI & Performance Reporting Team" & vbLf & _
sline2 & vbLf & _
sline3 & vbLf & vbLf & _
sLine4
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = strmaillist
.CC = ""
.BCC = ""
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
.send ' bugs out here
End With
Set OutMail = Nothing
Set OutApp = Nothing
ThisWorkbook.Activate
Sheets("Sheet1").Select
Application.ScreenUpdating = True: Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range(sRange2).Value = sConclusion '.
Application.ScreenUpdating = True: Application.ScreenUpdating = False
End Sub
You can try to check the validity of the recipient before sending, by using the .Resolve method of the Recipient object. Only valid recipients can be kept in the Recipient list of the mail item.
You might try this:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value <> "" Then
set r = .Recipients.Add(cell.value)
If Not r.Resolve then r.Delete '<~~ Removes invalid recipients
End If
Next
.send
End With