Multiple email error

[Akshay_divecha]

Dear Experts,

Getting error while sending email, need your advise on how to fix it..

[

Sub SendEmail()
'
' SendEmail Macro
'

'
row_number = 1

Do
DoEvents
    row_number = row_number + 1
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim OutMailBody As String


    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
    
        .To = Sheet1.Range("A" & row_number)
        .CC = Sheet1.Range("B" & row_number)
        .Subject = Sheet1.Range("J" & row_number)
        .Body = Sheet1.Range("I" & row_number)
        .Display   'or use .Display
    End With
    On Error GoTo 0
    
Loop Until Last_Row_IN_Column_A = Sheet1.Range("A50").End(xlUp)

    Set OutMail = Nothing
    Set OutApp = Nothing
      
MsgBox "Mail sent"
    
End Sub

 

[DanteAmor]

How about

Sub SendEmail()
' SendEmail Macro
  Dim OutApp As Object, OutMail As Object, i As Long
  '
  On Error Resume Next
  For i = 2 To Range("A" & Rows.Count).End(3).Row
    Set OutApp = CreateObject("outlook.application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
      .to = Sheet1.Range("A" & i)
      .CC = Sheet1.Range("B" & i)
      .Subject = Sheet1.Range("J" & i)
      .Body = Sheet1.Range("I" & i)
      .Display   'or use .Display
    End With
  Next
  Set OutMail = Nothing
  Set OutApp = Nothing
  MsgBox "Mail sent"
End Sub

 

[Akshay_divecha]

Thanks its working

 

[Akshay_divecha]

Instead of displaying the email i need to save it in drafts, can you help me how to incorporate in current code.