Excel Macro For Sending Email, Question About Email Body

[scottcutler]

Hello,

I wrote the macro below (with some help from an online posting) to send an email to the address in column "G", given the value in column "Q" is "yes". A snapshot of the excel spreadsheet is also included below. However, the problem is that the person with this email address has multiple items (rows) in the spreadsheet with value "yes" in column "Q". So every time I run the macro, they receive many emails.

I would like to amend the code so that every row with column "Q" being "yes" is sent in one email to the address given in column "G". The one email though, needs to contain data from all rows that have a value of "yes" in column "Q". Is it possible to embed the logical test within the body of the email to make this possible? Any help would be very much appreciated. Thanks a bunch!

A B C D E F G H I J K L M N O P Q # Name Submittal Type Subcontractor Contact Email Notify Days Submit Days Approve Days Onsite Hold Submitted Needed 031000 Concrete Formwork Formwork Release Agent action Core Mike Muhlena mikem@corestructuralservices.com 3/22/2016 42 5/3/2016 42 5/31/2016 14 6/14/2016 X YES 031000 Concrete Formwork Product Data action Core Mike Muhlena mikem@corestructuralservices.com 3/22/2016 42 5/3/2016 42 5/31/2016 14 6/14/2016 X NO 031000 Concrete Formwork Testing For Formwork Removal action Core Mike Muhlena mikem@corestructuralservices.com 3/22/2016 42 5/3/2016 42 5/31/2016 14 6/14/2016 X NO 031000 Concrete Formwork Shop Drawings action Core Mike Muhlena mikem@corestructuralservices.com 3/22/2016 42 5/3/2016 42 5/31/2016 14 6/14/2016 X NO <tbody> </tbody> <strike></strike>

<tbody>
</tbody>

Sub Test1()


Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range


Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "Q").Value) = "yes" Then


Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "DMPS Submittal Reminder"
.Body = "This email is a reminder that the " & Cells(cell.Row, "A").Value _
& ": " & Cells(cell.Row, "B").Value & ", " & Cells(cell.Row, "C").Value _
& " submittal package is due for submission on " & Cells(cell.Row, "J").Value & "." _
& " Specific information for this submittal" _
& " package can be found in the Project Specification. Please feel free" _
& " to contact me with any questions." _
& vbNewLine & vbNewLine & "Thank you,"
'.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell


cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[scottcutler]

Hi scottcutler,

Here is a modified version that allows you to insert or remove table heading rows and also to insert, remove or change columns' order. All you have to do is set proper values of the corresponding constants (see ‘Table structure constants’ at the beginning of the code).

[FONT=Consolas][SIZE=2][COLOR=navy]Sub Test3()

   [COLOR=green]'[/COLOR]
   [COLOR=green]' Table structure constants[/COLOR]
   Const bHEADINGS_ROWS As Byte = 2    [COLOR=green]' Number of table heading rows[/COLOR]
   Const bNUMBER_COL    As Byte = 1    [COLOR=green]' Column A [#][/COLOR]
   Const bNAME_COL      As Byte = 2    [COLOR=green]' Column B [Name][/COLOR]
   Const bSUBMITTAL_COL As Byte = 3    [COLOR=green]' Column C [Submittal][/COLOR]
   Const bEMAIL_COL     As Byte = 7    [COLOR=green]' Column G [Email][/COLOR]
   Const bSUBMIT_COL    As Byte = 10   [COLOR=green]' Column J [Submit][/COLOR]
   Const bNEEDED_COL    As Byte = 17   [COLOR=green]' Column Q [Needed][/COLOR]

   Dim sBodyText As String    [COLOR=green]' E-mail body text[/COLOR]
   Dim vMailArr As Variant    [COLOR=green]' Hold unique list of e-mail addresses[/COLOR]
   Dim vTest As Variant       [COLOR=green]' Used to test returned values[/COLOR]
   Dim iMailCnt As Integer
   Dim blError As Boolean
   Dim OutApp As Object
   Dim OutMail As Object
   Dim rMail As Range         [COLOR=green]' E-mail addresses range[/COLOR]
   Dim rCell As Range

   Application.ScreenUpdating = False
   Set OutApp = CreateObject("Outlook.Application")
   [COLOR=green]'[/COLOR]
   [COLOR=green]' Read e-mail addresses[/COLOR]
   With Range("A1").CurrentRegion
      Set rMail = .Columns(bEMAIL_COL).Offset(bHEADINGS_ROWS).Resize(.Rows.Count - bHEADINGS_ROWS)
   End With
   ReDim vMailArr(rMail.Rows.Count - 1)
   iMailCnt = 0
   On Error Resume Next
   [COLOR=green]'[/COLOR]
   [COLOR=green]' Create e-mail list with no duplications[/COLOR]
   For Each rCell In rMail.Rows
      If Not IsEmpty(rCell.Value) Then
         vTest = Application.Match(rCell.Value, vMailArr, 0)
         If Err.Number > 0 Or Not IsNumeric(vTest) Then
            vMailArr(iMailCnt) = rCell.Value
            iMailCnt = iMailCnt + 1
         End If
         Err.Clear
      End If
   Next rCell
   ReDim Preserve vMailArr(iMailCnt - 1)
   On Error GoTo 0
   [COLOR=green]'[/COLOR]
   [COLOR=green]' Send e-mails loop[/COLOR]
   Range("A1").AutoFilter
   For iMailCnt = LBound(vMailArr) To UBound(vMailArr)
      [COLOR=green]'[/COLOR]
      [COLOR=green]' Set appropriate filter[/COLOR]
      With Range("A1")
         .AutoFilter Field:=bEMAIL_COL, Criteria1:=vMailArr(iMailCnt)
         .AutoFilter Field:=bNEEDED_COL, Criteria1:="yes"
      End With
      On Error Resume Next
      vTest = rMail.SpecialCells(xlCellTypeVisible).Address
      blError = Err.Number > 0
      On Error GoTo 0
      If Not blError Then        [COLOR=green]' Send e-mail[/COLOR]
         [COLOR=green]'[/COLOR]
         [COLOR=green]' Build body text[/COLOR]
         sBodyText = "This email is a reminder that the following submittal packages are due" _
            & " for submission. Specific information for these submittal" _
            & " packages can be found in the Project Specification. Please feel free" _
            & " to contact me with any questions." & vbNewLine & vbNewLine & "Thank you," _
            & vbNewLine & vbNewLine
         For Each rCell In rMail.SpecialCells(xlCellTypeVisible)
            With rCell
            sBodyText = sBodyText _
               & .Offset(, bSUBMIT_COL - .Column).Value & ": " _
               & .Offset(, bNUMBER_COL - .Column).Value & " " _
               & .Offset(, bNAME_COL - .Column).Value & ", " _
               & .Offset(, bSUBMITTAL_COL - .Column).Value & vbNewLine
            End With
         Next rCell
         [COLOR=green]'[/COLOR]
         [COLOR=green]' Send the e-mail[/COLOR]
         Set OutMail = OutApp.CreateItem(0)
         On Error Resume Next
         With OutMail
            .To = vMailArr(iMailCnt)
            .Subject = "DMPS Submittal Reminder"
            .Body = sBodyText
            [COLOR=green]'.Attachments.Add ("C:\test.txt")[/COLOR]
            .Send
         End With
         On Error GoTo 0
         Set OutMail = Nothing
      End If
   Next iMailCnt
   [COLOR=green]'[/COLOR]
   [COLOR=green]' Clear the filter[/COLOR]
   ActiveSheet.AutoFilterMode = False
   Set rCell = Nothing
   Set rMail = Nothing
   Set OutApp = Nothing
   Set OutMail = Nothing
   [COLOR=green]'[/COLOR]
   [COLOR=green]' Enable environment[/COLOR]
   Application.ScreenUpdating = True

End Sub
[/COLOR][/SIZE][/FONT]

This code runs wonderfully! Thank you so much for all of your assistance. Very, very much appreciated. Take care,

 

[Mohammad Basem]

Al-hamdullah, you are most welcome and thank you for the feedback!
All the best