Well, I question your sanity, but here you go. This will do 3 at a time for testing. Adjust as needed.
Option Explicit
Sub Send_Email_Using_VBA()
Dim BegRw As Long, CurRw As Long, MsgCnt As Long
Dim objOutlook As Object, Msg As Variant, Resp As Long
Const MsgLimit = 3
Set objOutlook = CreateObject("Outlook.Application")
CurRw = 1
Do Until Cells(CurRw, 1).Value = ""
MsgCnt = 1
BegRw = CurRw
Do Until MsgCnt > MsgLimit Or Cells(CurRw, 1).Value = ""
Set Msg = objOutlook.CreateItem(0)
With Msg
.To = Cells(CurRw, 1).Value
.Subject = Cells(CurRw, 2).Value
.Display
End With
MsgCnt = MsgCnt + 1
CurRw = CurRw + 1
Loop
If Cells(CurRw, 1).Value <> "" Then
If MsgBox("Messages " & BegRw & " through " & CurRw - 1 & " have been created. Click OK to continue.", _
vbOKCancel, "Email Messages") <> vbOK Then
CurRw = Rows.Count
End If
End If
Loop
If CurRw < Rows.Count Then
MsgBox "Messages " & BegRw & " through " & CurRw - 1 & " have been created. Process completed.", , "Email Messages"
End If
Set Msg = Nothing
Set objOutlook = Nothing
End Sub
Bookmarks