Sending an email via VBA

[Anthony86]

Hi All,

I'm using some code from the net that sends an email if the due date is close but what I want it to do is if the name in column "F" is the same then send multiple lines in one email, if its different then send a separate email.

Is this possible?

This is the code that I'm using

Dim Email As String, Subj As String
    Dim Msg As String
    Dim LastRow As Long, NextRow As Long, RowNo As Long
    Dim wsEmail As Worksheet
    Dim OutApp As Object
    Dim OutMail As Object

    Set wsEmail = ThisWorkbook.Sheets("SheetName")
    
    With wsEmail
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For RowNo = 2 To LastRow
            'Change "Date + 30" to suit your timescale
            
            If .Cells(RowNo, "K") = "" And .Cells(RowNo, "E") <= Date + 7 Then
                
                On Error Resume Next
                Set OutApp = GetObject("Outlook.Application")
                    On Error GoTo 0
                    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
                    Do: Loop Until Not OutApp Is Nothing
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    Email = "User@email.com" 'Change to cell containing e-mail address
                    Subj = "Reminder for Destruction" 'Change to cell containing subject or type subject
                    'Msg = ""
                    
                    Msg = "Hello" & "," & vbCrLf & vbCrLf _
                        & "This is an automated e-mail to let you know that box" & vbCrLf _
                        & wsEmail.Cells(RowNo, "A") & vbCrLf _
                        & "Is due for destruction on " & wsEmail.Cells(RowNo, "E") & vbCrLf _
                        & "Many Thanks, " & vbCrLf
                        
                    .To = Email
                    .CC = ""
                    .SentOnBehalfOfName = "Your User Name" ' This is optional, you can delete this line.
                    .Subject = Subj
                    .ReadReceiptRequested = False
                    .Body = Msg
                    .Display

                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
            .Cells(RowNo, "K") = "S"
            .Cells(RowNo, "L") = "E-mail sent on: " & Now()
        End If
        Next
    End With

 

[DanteAmor]

But in addition to checking the date you also want to check the name?
Or do you just want to check the name?

 

[Anthony86]

Hi,
Yes I want to check the date, then group together in separate emails depending on the name. Hopefully that makes sense

 

[DanteAmor]

Hi @Anthony86,

if the name in column "F" is the same then send multiple lines in one email

But you didn't mention which lines should go in one email.

I put a proposal for you to review:

Sub test()
  Dim Email As String, Subj As String, Msg As String, wBox As String
  Dim RowNo As Long, i As Long, ky As Variant, cad As Variant
  Dim wsEmail As Worksheet, OutApp As Object, OutMail As Object, dic As Object
 
  Set wsEmail = ThisWorkbook.Sheets("SheetName")
  Set dic = CreateObject("scripting.dictionary")
 
  With wsEmail
    For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
      If .Cells(RowNo, "K") = "" And .Cells(RowNo, "E") <= Date + 7 Then
        If dic.exists(.Cells(RowNo, "F").Value) Then
          dic(.Cells(RowNo, "F").Value) = dic(.Cells(RowNo, "F").Value) & RowNo & "|"
        Else
          dic(.Cells(RowNo, "F").Value) = RowNo & "|"
        End If
      End If
    Next
    
    For Each ky In dic.keys
      cad = Left(dic(ky), Len(dic(ky)) - 1)
      cad = Split(cad, "|")
      wBox = ""
      For i = 0 To UBound(cad)
        wBox = wBox & " " & wsEmail.Cells(cad(i), "A") & _
               " Is due for destruction on " & wsEmail.Cells(cad(i), "E") & vbCrLf
        .Cells(cad(i), "K") = "S"
        .Cells(cad(i), "L") = "E-mail sent on: " & Now()
      Next
      On Error Resume Next
      Set OutApp = GetObject("Outlook.Application")
      On Error GoTo 0
      If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
      Do: Loop Until Not OutApp Is Nothing
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
        Email = "User@email.com" 'Change to cell containing e-mail address
        Subj = "Reminder for Destruction" 'Change to cell containing subject or type subject
        Msg = "Hello " & ky & "," & vbCrLf & vbCrLf _
          & "This is an automated e-mail to let you know that box" & vbCrLf _
          & wBox & vbCrLf & "Many Thanks, " & vbCrLf
        .To = Email
        .CC = ""
        .SentOnBehalfOfName = "Your User Name" ' This is optional, you can delete this line.
        .Subject = Subj
        .ReadReceiptRequested = False
        .Body = Msg
        .Display
      End With
      Set OutApp = Nothing
      Set OutMail = Nothing
    Next
  End With
End Sub

 

[Anthony86]

Apologies! I'm working with destruction dates and when the date is near I basically want an email sent to remind me, now the criteria for that is just the destruction date but I also want to filter it by account. So if I have 10 boxes due for destruction all belonging to one account then that information will be sent in 1 email, if I have more due dates but relating to different accounts then I want that in a separate email.

I just quickly chucked this together to give you an idea of how my spreadsheet will look. The information I will need in the emails is box number, destruction date, account name.

I tested your code above and it pulled stuff that didn't have a date, and ignored the rows that did have them (Not every row will have a destruction date)

 

[Anthony86]

Apologies! I'm working with destruction dates and when the date is near I basically want an email sent to remind me, now the criteria for that is just the destruction date but I also want to filter it by account. So if I have 10 boxes due for destruction all belonging to one account then that information will be sent in 1 email, if I have more due dates but relating to different accounts then I want that in a separate email.

I just quickly chucked this together to give you an idea of how my spreadsheet will look. The information I will need in the emails is box number, destruction date, account name.

View attachment 1119

I tested your code above and it pulled stuff that didn't have a date, and ignored the rows that did have them (Not every row will have a destruction date)

Ignore my previous email its been a long morning LOL, it works!!!

 

[Anthony86]

I've played with the code a little more and most of it works perfect, apart from if I leave column 'E' blank it still emails it? How can I stop this from happening as not all rows will be populated with a destruction date.

Everything else works great and I really appreciate that!

 

[daverunt]

Hi,

Might be a bit early for Dante to respond so I'll have a go.
Added a check if 'E' is blank it should skip that row.
If it does have content it continues to the date check line of code

 With wsEmail
    For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
    If .Cells(RowNo, "E") <> "" Then
      If .Cells(RowNo, "K") = "" And .Cells(RowNo, "E") <= Date + 7 Then
        If dic.exists(.Cells(RowNo, "F").Value) Then
          dic(.Cells(RowNo, "F").Value) = dic(.Cells(RowNo, "F").Value) & RowNo & "|"
        Else
          dic(.Cells(RowNo, "F").Value) = RowNo & "|"
        End If
      End If
      End If
    Next
[/Code[

 

[DanteAmor]

I've played with the code a little more and most of it works perfect, apart from if I leave column 'E' blank it still emails it? How can I stop this from happening as not all rows will be populated with a destruction date.

Everything else works great and I really appreciate that!

Change this line
If .Cells(RowNo, "K") = "" And .Cells(RowNo, "E") <= Date + 7 Then

By this:
If .Cells(RowNo, "K") = "" And .Cells(RowNo, "E") <> "" And .Cells(RowNo, "E") <= Date + 7 Then

 

[Anthony86]

Hi,

This done the trick, thank you!!