Sending automated emails from excel using VBA

Hey all,

So i am trying to send automatic emails using excel source information and VBA code. However I cannot seem to put it together. I searched this forum and found this http://www.excelforum.com/excel-prog...-in-range.html

This kinda works, BUT for every line - which is not desirable. I do not want it to send email for every line i want to summarize it by email but - and send only like 15 emails instead of i.e 65 emails for every line.

How can it be done, please help.

My table looks like this:

Period	Number	Provider	Service	Count	Duration	Total	Email
201504	31987	ETV	Phone	12	23	23432	[email protected]
201504	31987	ETV	Phone	12	23	23432	[email protected]
201504	31987	STV	Phone	12	23	23432	[email protected]
201504	31987	STV	Phone	12	23	23432	[email protected]

And code from the other thread looks like this.

Sub email()
    Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
       
    For i = 1 To Range("c65536").End(xlUp).Row
        Set OutMail = OutApp.CreateItem(0)
                
            strto = Cells(i, 8)
            strsub = "Missing Books"
            strbody = "Good day," & vbNewLine & _
                "We are missing below books:" & vbNewLine & _
                Cells(i, 1) & Chr(32) & Cells(i, 2) & Cells(i, 3) & Cells(i, 5) & Cells(i, 6) & vbNewLine & vbNewLine & _
                "brgds," & vbNewLine & _
                "Alex"
                
            With OutMail
                .To = strto
                .Subject = strsub
                .Body = strbody
                '.Send
                .display
                                
            End With
            On Error Resume Next
        
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

End product should look like this:

message TO [email protected]

Hello,

Here is the report:

Period	Number	Provider	Count	Duration
201504	31987	STV	12	23
201504	31987	STV	12	23

Best,
Annux

Try this...

Sub email()
    Dim Lr As Long
    Dim rngEmails As Range, rngEmail As Range, rngLine As Range
    Dim OutApp As Object, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    Application.ScreenUpdating = False
    
    Lr = Range("H" & Rows.Count).End(xlUp).Row
    Range("H1:H" & Lr).AdvancedFilter xlFilterInPlace, Unique:=True
    Set rngEmails = Range("H2:H" & Lr).SpecialCells(xlCellTypeVisible)
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
       
    For Each rngEmail In rngEmails
    
        Range("H1:H" & Lr).AutoFilter 1, rngEmail.Value
                
        strbody = "Good day," & vbNewLine & "We are missing below books:" & vbNewLine
        For Each rngLine In Range("A2:A" & Lr).SpecialCells(xlCellTypeVisible)
            strbody = strbody & rngLine & Chr(32) & rngLine.Offset(, 1) & _
                      rngLine.Offset(, 2) & rngLine.Offset(, 4) & rngLine.Offset(, 5) & vbNewLine
        Next rngLine
        strbody = strbody & vbNewLine & "brgds," & vbNewLine & "Alex"
            
        With OutApp.CreateItem(0)
            .To = rngEmail.Value
            .Subject = "Missing Books"
            .Body = strbody
            '.Send
            .Display
        End With
        
    Next
    
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
    Set OutApp = Nothing
    
End Sub