How to VBA MAilto all emails in a colum - excel

Question

Hi I have all my clients email address in row A on my excel sheet Named "Email". I have created the code below so that a box pops up when I press a bottom on the sheet and I can type the subject, and a few body lines. I want to be able to send the same message to all my client. IE for promotion or if we had to shut the office unexpectedly ect. Can any one help please?
Private Sub CommandButtonSend_Click()
Dim Email_Subject, Email_Send_From, Email_Body1, Email_Body2, Email_Sig, Email_Twitter As String
Dim Mail_Object, Mail_Single As Variant
Dim emailrange As Range, cell As Range
Dim Email_Send_To As String
Set emailrange = Worksheets("Email").Range("A2:A4")
For Each cell In emailrange
Email_Send_To = Email_Send_To & "j" & cell.Value
Next
Email_Send_To = Mid(Email_Send_To, 2)
On Error Resume Next
Email_Subject = UserFormTemplate.TextBoxSubject.Text
Email_Send_From = "shaunha#coversure.co.uk"
Email_Body1 = UserFormTemplate.TextBoxLine1.Text
Email_Body2 = UserFormTemplate.TextBoxLine2.Text
Email_Sig = UserFormTemplate.TextBoxSig.Text
Email_Twitter = UserFormTemplate.TextBoxTwitter.Text
On Error GoTo debugs
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body1 & vbNewLine & Email_Body2 & vbNewLine & vbNewLine & "Shaun Harrison Insurance Consultant" & vbNewLine & "Tel: [phone] / shaunha#coversure.co.uk" & vbNewLine & vbNewLine & Email_Twitter
.send
End With
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End
End Sub

Answer 1

Sub SendySend()
With ActiveSheet
EndRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
RowCount = 4
For XCount = 4 To EndRow
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.application")
Dim olmail As Outlook.MailItem
Set olmail = olApp.CreateItem(olMailItem)
If Range("D" & RowCount).Value = "Yes" Then
olmail.To = Range("A" & RowCount).Value
olmail.Subject = Range("B" & RowCount).Value
olmail.Body = Range("C" & RowCount).Value
olmail.Send
Else
DontSend = 1 'This Doesn't do anything at all, it's just for clarity
End If
RowCount = RowCount + 1
Next
End Sub