Sending Email - Loop Until last row (skipping blank cells)

[agencare10]

Hello,

I am trying to setup an excel VBA (new to this) and I have it setup so that any email address in column B will receive a mass email from my work. The only problem is that the excel spreadsheet is shared so I have designated rows to each coworker which will end up leaving blank cells in column B. I currently have it setup so that if there are no blank cells it will loop until the last cell and send emails out to all email address in column B. But if there is a blank cell in column B in between the emails, it will not go to the next cell with an email address in it. Below is the VBA code for what I have. I wouldn't like to modify it too much, if someone could just help me on how to all emails in column b, skipping all blank cells!

Sub SendEmail(what_address As String, subject_line As String, mail_body As String)

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)

olMail.To = what_address
olMail.Subject = subject_line
olMail.Body = mail_body
olMail.Send


End Sub

Sub SendMassEmail()


row_number = 2

Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
mail_body_message = Sheet1.Range("H3")
full_name = Sheet1.Range("C" & row_number) & " " & Sheet1.Range("D" & row_number)
mail_body_message = Replace(mail_body_message, "replace_name_here", full_name)
Call SendEmail(Sheet1.Range("B" & row_number), "This is a test email", mail_body_message)
Loop Until row_number = Sheet1.Range("B99999").End(xlUp).Row


MsgBox "Emails Sent"

End Sub

[pjwhitfield]

Please Login or Register  to view this content.

And add a function (isEmail) to check if its a valid email

Please Login or Register  to view this content.

There are probably more comprehensive Functions for email checking available on google but that will do the basic check.

[agencare10]

Thank you so much! That worked, I really appreciate it.