Auto mail to take up email address from worsheet & send

[Mahesh Rana]

Hi!

VBA to send auto mail by extracting mail address from worksheet, BUT
Not able to extract address from the whole column. It works - but on single cell if I write Range ("A1").
Pls. suggest the correction to be done (I think it should be in - marked as Red)

Option Explicit


Private Sub CommandButton1_Click()
    On Error GoTo ErrHandler
    
    ' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
        
    ' CREATE EMAIL OBJECT.
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(0)
       
    On Error Resume Next
    With objEmail
    .To = Range("A:A")
    .CC = Range("B:B")
    .BCC = Range("C:C")
    .Subject = "COLD CHAIN DISPATCHES" & Date
    .Body = "Pls. have the details in attachment."
    .Attachments.Add ("C:\COLD CHAIN.xlsx")
    .Send
End With
    
    ' CLEAR.
    Set objEmail = Nothing:    Set objOutlook = Nothing
        
ErrHandler:
    '
End Sub

 

[nardagus]

Try this one. It will check last row with email address in column A and will loop through every row starting from row 2 through last row.
Note. I haven't checked this modifications.
Changes I made are in RED.

Option Explicit



Private Sub CommandButton1_Click()
    On Error GoTo ErrHandler
[COLOR=#ff0000]Dim lrow as Long 'last row[/COLOR]

[COLOR=#ff0000]with activesheet
      lrow = .Range("A" & .Rows.Count).End(xlUP).Row
end with[/COLOR]
    
    ' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
        
    ' CREATE EMAIL OBJECT.
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(0)

[COLOR=#ff0000]for i = 2 to lrow[/COLOR]
       
    On Error Resume Next
    With objEmail
[COLOR=#ff0000]    .To = Range("A" & i)[/COLOR]
[COLOR=#ff0000]    .CC = Range("B" & i)[/COLOR]
[COLOR=#ff0000]    .BCC = Range("C" & i)[/COLOR]
    .Subject = "COLD CHAIN DISPATCHES" & Date
    .Body = "Pls. have the details in attachment."
    .Attachments.Add ("C:\COLD CHAIN.xlsx")
    .Send
    End With

[COLOR=#ff0000]next i[/COLOR]
    
    ' CLEAR.
    Set objEmail = Nothing:    Set objOutlook = Nothing
        
ErrHandler:
    '
End Sub

 

[Mahesh Rana]

Thanks nardagus for your support.
But their is some issue.
I Had made a small intrusion in Red.
But is sends mail for only the 2nd row of all three columns. I need to send to all the persons in those three columns.

Option Explicit



Private Sub CommandButton1_Click()
    On Error GoTo ErrHandler
Dim lrow as Long 'last row

with activesheet
      lrow = .Range("A" & .Rows.Count).End(xlUP).Row
end with
    
    ' SET Outlook APPLICATION OBJECT.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
        
    ' CREATE EMAIL OBJECT.
    Dim objEmail As Object
    Set objEmail = objOutlook.CreateItem(0)

[COLOR=#ff0000]Dim I As Integer[/COLOR]
for i = 2 to lrow
       
    On Error Resume Next
    With objEmail
    .To = Range("A" & i)
    .CC = Range("B" & i)
    .BCC = Range("C" & i)
    .Subject = "COLD CHAIN DISPATCHES" & Date
    .Body = "Pls. have the details in attachment."
    .Attachments.Add ("C:\COLD CHAIN.xlsx")
    .Send
    End With

next i
    
    ' CLEAR.
    Set objEmail = Nothing:    Set objOutlook = Nothing
        
ErrHandler:
    '
End Sub

 

[nardagus]

My bad. LOOP start was in a wrong place in a code.

Private Sub CommandButton1_Click()On Error GoTo ErrHandler
Dim lrow As Long 'last row


With ActiveSheet
    lrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With


' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")


' CREATE EMAIL OBJECT.
Dim objEmail As Object
Dim I As Integer


For I = 2 To lrow


    Set objEmail = objOutlook.CreateItem(0)
    
    On Error Resume Next
    With objEmail
        .To = Range("A" & I)
        .CC = Range("B" & I)
        .BCC = Range("C" & I)
        .Subject = "COLD CHAIN DISPATCHES" & Date
        .Body = "Pls. have the details in attachment."
        .Attachments.Add ("C:\COLD CHAIN.xlsx")
        .Send
    End With


Next I


' CLEAR.
Set objEmail = Nothing: Set objOutlook = Nothing


ErrHandler:
'
End Sub

 

[Mahesh Rana]

It works fine.
Thanks a lot.

 

[nardagus]

You're welcome.