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

 

[Mohammad Basem]

My mistake!

Please replace all occurrences of rCl with rCell. There are two; the line you've mentioned and the next line.

 

[Mohammad Basem]

With regard to the error traps, the example that I used set them up this way.

Do you have the link?

 

[scottcutler]

Do you have the link?

Its almost there! So right now, when I run the program, it sends two emails to "Mike Muhlena", and one email to "Josh Smith" (column F). The body of the email contains standard text, and then cell references to all three rows of data where column Q = "yes" (some of which are Mike Muhlena's items, and some are Josh Smith's items) and looks like this.

This email is a reminder that
the following submittal packages are due for submission by the given deadlines.
Specific information for these submittal packages can be found in the Project
Specification. Please feel free to contact me with any questions.


Thank you,




5/3/2016: 03100 Concrete formwork, Formwork Release Agent
5/3/2016: 03100 Concrete formwork, Product Data
5/3/2016: 03100 Masonry, Shop Drawings


My goal is to have the macro send only upto one email per person, and only contain cell references (i.e. "5/3/2016: 03100 Concrete Formwork, Formwork Release Agent") for their items (i.e. the email should be sent to the address in column G, and should only contain cell references for rows where the value in column G matches the email address of the recipient). I have been working through this, but am stumped on these last two details. If the recipient in column G has no items with a "yes" in column Q, no email should be sent. A snapshot of the spreadsheet, and also the revised code are shown below. Any assistance would be very much appreciated! Thanks for all the help so far!

Also, regarding the error traps, I have been looking for the original example that I used, but so far have not been able to find it. I will continue to search this evening, and post the link as soon as I am able to find it. Thanks again, it is very much appreciated!

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 YES 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 Masonry Shop Drawings action SMI Josh Smith josh.smith@smi.com 3/22/2016 42 5/3/2016 42 5/31/2016 14 6/14/2016 X YES <tbody> </tbody> <strike></strike>

<tbody>
</tbody>

Sub Test2()

Dim sBodyText As String
Dim OutApp As Object
Dim OutMail As Object
Dim rCell As Range
Dim cCell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
'
' Send e-mails
On Error GoTo CleanUp
For Each rCell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If rCell.Value Like "?*@?*.?*" And _
LCase(Cells(rCell.Row, "Q").Value) = "yes" Then
'
' Build body text
sBodyText = "This email is a reminder that the following submittal packages are due" _
& " for submission by the given deadlines. 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 cCell In ActiveSheet.Range("A1:Q190").Rows
If LCase(cCell.Cells(, "Q")) = "yes" Then
sBodyText = sBodyText & cCell.Cells(, "J").Value & ": " & cCell.Cells(, "A").Value & " " _
& cCell.Cells(, "B").Value & ", " & cCell.Cells(, "C").Value & vbNewLine
End If
Next cCell
'
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = rCell.Value
.Subject = "DMPS Submittal Reminder"
.Body = sBodyText
'.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next rCell

CleanUp:
Set rCell = Nothing
Set OutApp = Nothing
Set OutMail = Nothing
Application.ScreenUpdating = True

End Sub

 

[tonyyy]

The suggestion by @Momentman early in this thread to filter the sheet seemed like a good approach. And the sBodyText loop coded by @Mohammad Basem provided a good solution to a specific issue. The code below offers a hybrid of the two...

Sub EmailFromExcel()

Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim crit As Range
Dim i As Long
Dim j As Long
Dim kount As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim sBodyText As String

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set ws1 = ThisWorkbook.ActiveSheet
Set ws2 = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Set OutApp = CreateObject("Outlook.Application")
LastRow = ws1.Cells(Rows.Count, "G").End(xlUp).Row

'Create criteria list
ws1.Range("G2:G" & LastRow).Copy Destination:=ws2.Range("AA2")
ws2.Range("AA2:AA" & LastRow).RemoveDuplicates Columns:=1, Header:=xlNo
Set crit = ws2.Range("AA2:AA" & Cells(Rows.Count, "AA").End(xlUp).Row)
kount = ws2.Range("AA2:AA" & Cells(Rows.Count, "AA").End(xlUp).Row).Count

'Turn on AutoFilter
If Not ws1.AutoFilterMode Then
  ws1.Range("G2").AutoFilter
End If

'Loop through criteria in Column G and Column Q
For i = 1 To kount
    With ws1.Range("G1").CurrentRegion
        .AutoFilter field:=7, Criteria1:=crit(i).Value
        .AutoFilter field:=17, Criteria1:="YES"
    End With
    
    'Copy filtered list to temporary worksheet
    ws1.Range("G1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=ws2.Range("A1")
    If ws2.Range("A2") <> "" Then
        LastRow2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        ' Build body text
        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 j = 2 To LastRow2
            sBodyText = sBodyText & ws2.Range("A" & j).Value & ": " & ws2.Range("B" & j).Value & ", " & ws2.Range("C" & j).Value _
            & ", " & ws2.Range("J" & j).Value & vbNewLine
        Next j
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = ws2.Range("G2")
            .Subject = "DMPS Submittal Reminder"
            .Body = ws2.Range("F2") & "," & vbNewLine & vbNewLine & sBodyText
        '    .Send
            .display
        End With
        Set OutMail = Nothing
    End If
    
    ws2.Range("A1").CurrentRegion.Clear
    ws1.ShowAllData
Next i

ws2.Delete
ws1.AutoFilterMode = False
Set OutApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

The code is currently set to .Display the mail messages rather than .Send.

Cheers,

tonyyy

 

[Mohammad Basem]

Hi cottcutler,

My goal is to have the macro send only upto one email per person…

This made things clearer, try this

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Sub Test2()

   Dim sBodyText As String
   Dim vMailArr As Variant
   Dim vTest As Variant
   Dim iMailCnt As Integer
   Dim OutApp As Object
   Dim OutMail As Object
   Dim rMail As Range
   Dim rCell As Range

   Application.ScreenUpdating = False
   Set OutApp = CreateObject("Outlook.Application")
   [COLOR="Green"]'[/COLOR]
   [COLOR="Green"]' Read e-mail addresses[/COLOR]
   With Range("A2").CurrentRegion
      Set rMail = .Columns("G").Offset(1).Resize(.Rows.Count - 1)
   End With
   ReDim vMailArr(rMail.Rows.Count - 1)
   iMailCnt = 0
   On Error Resume Next
   For Each rCell In rMail.Rows
      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
   Next rCell
   ReDim Preserve vMailArr(iMailCnt - 1)
   On Error GoTo 0
   [COLOR="Green"]'[/COLOR]
   [COLOR="Green"]' Send e-mails[/COLOR]
   On Error GoTo CleanUp
   Range("A1").AutoFilter
   For iMailCnt = LBound(vMailArr) To UBound(vMailArr)
      [COLOR="Green"]'[/COLOR]
      [COLOR="Green"]' Set appropriate filter[/COLOR]
      With Range("A1")
         .AutoFilter Field:=7, Criteria1:=vMailArr(iMailCnt)
         .AutoFilter Field:=17, Criteria1:="yes"
      End With
      [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(, 3).Value & ": " _
            & .Offset(, -6).Value & " " _
            & .Offset(, -5).Value & ", " _
            & .Offset(, -4).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
   Next iMailCnt

CleanUp:
   [COLOR="Green"]'[/COLOR]
   [COLOR="Green"]' Clear the filter[/COLOR]
   ActiveSheet.AutoFilterMode = False
   Set rCell = Nothing
   Set rMail = Nothing
   Set OutApp = Nothing
   Set OutMail = Nothing
   Application.ScreenUpdating = True

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

 

[Mohammad Basem]

Hi cottcutler,

With regard to the error traps, the example that I used set them up this way.

I still have concerns about the error traps, as both are misleading. I kept both of them, but would appreciate posting the link of the example to see whether they should be kept or removed.

 

[scottcutler]

Hi cottcutler,



I still have concerns about the error traps, as both are misleading. I kept both of them, but would appreciate posting the link of the example to see whether they should be kept or removed.

Thanks to everyone for all of the help!

The link to the original code that I used as an example is: https://social.msdn.microsoft.com/F...a-4f98-9749-79cac38faae4/email?forum=exceldev

Mohammad Basem: The macro that you wrote seems to be working quite well. It is very much appreciated. Two small items have come up that I haven't been able to solve. First, I believe the macro sends one email to each contact regardless of whether they have any rows with a "yes" in column Q. Ideally, the macro would only send emails to those contacts who have outstanding items (where there is at least one row with a "yes" in the Q column). Second, the body of every email references one row of cells that I would prefer it didn't. It would be great if the cell references returning "Submit: # Name, Submittal" in every email could be removed.

If the spreadsheet looked like this:

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

YES

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

Masonry

Shop Drawings

action

SMI

Josh Smith

josh.smith@smi.com

3/22/2016

42

5/3/2016

42

5/31/2016

14

6/14/2016

X

NO

<tbody>
</tbody>

Ideally, one email would be written to Mike Muhlena at Core, and no email would be written to Josh Smith at SMI. Currently they are both receiving one email.

Next, The body of the email to Mike Muhlena populates very close to correctly, it looks like this:

This email is a reminder that
the following submittal packages are due for submission by the given deadlines.
Specific information for these submittal packages can be found in the Project
Specification. Please feel free to contact me with any questions.


Thank you,

Submit: # Name, Submittal
5/3/2016: 03100 Concrete formwork, Formwork Release Agent
5/3/2016: 03100 Concrete formwork, Product Data

The macro does a good job of populating the email with cell references from the correct rows (the rows with a "yes" in column Q). However, every email has the line "Submit: # Name, Submittal". Ideally, this text would be removed. Thank you again, very much. Please let me know if there are any other clarifications I can make to assist your process. Best.

Tonyyy, thank you as well for your code. When I this macro, I have gotten some error messages including "Method 'To" of object'_MailItem' failed. When I run the debug, it highlights "Set ws2 = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))" Again, all of your help is so very much appreciated. Thanks!

 

[Mohammad Basem]

Hi scottcutler,

Thank you for the link!

…every email has the line "Submit: # Name, Submittal". Ideally, this text would be removed.

Using the sample you've posted, I didn't get this line in the body of the e-mail. Have a look at these 2 images,

E-mail 1
E-mail 2

The code considers table headings on row 1, is it the same with you?

Ideally, one email would be written to Mike Muhlena at Core, and no email would be written to Josh Smith at SMI. Currently they are both receiving one email.

I received error instead of sending the e-mail. Here is a modified version. Please let me know how it is goes.

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Sub Test2()

   Dim sBodyText As String
   Dim vMailArr As Variant
   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
   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("G").Offset(1).Resize(.Rows.Count - 1)
   End With
   ReDim vMailArr(rMail.Rows.Count - 1)
   iMailCnt = 0
   On Error Resume Next
   For Each rCell In rMail.Rows
      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
   Next rCell
   ReDim Preserve vMailArr(iMailCnt - 1)
   On Error GoTo 0
   [COLOR="Green"]'[/COLOR]
   [COLOR="Green"]' Send e-mails[/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:=7, Criteria1:=vMailArr(iMailCnt)
         .AutoFilter Field:=17, 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(, 3).Value & ": " _
               & .Offset(, -6).Value & " " _
               & .Offset(, -5).Value & ", " _
               & .Offset(, -4).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"]' Enale environment[/COLOR]
   Application.ScreenUpdating = True

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

 

[scottcutler]

Hi scottcutler,

Thank you for the link!



Using the sample you've posted, I didn't get this line in the body of the e-mail. Have a look at these 2 images,

E-mail 1
E-mail 2

The code considers table headings on row 1, is it the same with you?



I received error instead of sending the e-mail. Here is a modified version. Please let me know how it is goes.

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

   Dim sBodyText As String
   Dim vMailArr As Variant
   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
   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("G").Offset(1).Resize(.Rows.Count - 1)
   End With
   ReDim vMailArr(rMail.Rows.Count - 1)
   iMailCnt = 0
   On Error Resume Next
   For Each rCell In rMail.Rows
      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
   Next rCell
   ReDim Preserve vMailArr(iMailCnt - 1)
   On Error GoTo 0
   [COLOR=green]'[/COLOR]
   [COLOR=green]' Send e-mails[/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:=7, Criteria1:=vMailArr(iMailCnt)
         .AutoFilter Field:=17, 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(, 3).Value & ": " _
               & .Offset(, -6).Value & " " _
               & .Offset(, -5).Value & ", " _
               & .Offset(, -4).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]' Enale environment[/COLOR]
   Application.ScreenUpdating = True

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

Thank you! Yes, you are correct, the problem was with my excel spreadsheet. I actually had an additional row above the column headings with text. When I remove the extra row, the macro works exactly as desired. Thank you so much! My assumption is that if I wanted to put the addition row of text back in, I would just need to find everywhere in the code that says "Range("A1")", and change to "Range("A2")"? Again, thank you so much for all of your assistance. I have revised the spreadsheet snapshot below to include the top row of text for your reference. This top row of text is merged across all columns in the real spreadsheet.

A

B

C

D

E

F

Submittal Schedule 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

YES

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

Masonry

Shop Drawings

action

SMI

Josh Smith

josh.smith@smi.com

3/22/2016

42

5/3/2016

42

5/31/2016

14

6/14/2016

X

NO

<tbody>
</tbody>

 

[Mohammad Basem]

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]