Emailing through Excel table

Question

I am attempting to email to all email addresses in a table, with the subject line being the corresponding order number or numbers.

The Table has Five columns - "Line Number", "Order Number", "Suppler/Manf.Item Number", "Supplier Name" and "Email Address"

There can be duplicates, but the subject must contain each PO only once.

No CC, or BCC is required

The Body of the Email is to list the PO's with their associated line items.

Hello, We require an update as to the following:

EX
PO86001763
Line Item 2
Line Item 1

Please Send an update as to the status of these line items. Providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates.

(These being able to be edited would be a boon)

The table is made from an import and format macro, it will always be in the same format, but will contain different data. The amount of data can increase or decrease depending on the week.

Here is my attempt.

Private Sub CommandButton2_Click()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Dim I As Integer
Dim X As Integer
Dim C As Object
Dim firstaddress As Variant
Dim Nrow As Boolean

Set tb = ActiveSheet.ListObjects("Table10")

For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
    emAddress = tb.DataBodyRange.Cells(I, tb.ListColumns("Email Address").Index)
    For X = LBound(myArray1) To UBound(myArray1)
        On Error Resume Next
        If emAddress = myArray1(X) Then GoTo goToNext
    Next X
    On Error GoTo 0
    subjectLine = "Order(s) # "
    ReDim Preserve myArray1(1 To nameCounter)
    myArray1(nameCounter) = emAddress
    nameCounter = nameCounter + 1
    lineCounter = 1
    With tb.ListColumns("Email Address").Range
        Set C = .Find(emAddress, LookIn:=xlValues)
        If Not C Is Nothing Then
            firstaddress = C.Address
            Beep
            arrayCounter = arrayCounter + 1
            Do
                Nrow = C.Row - 1
                If lineCounter = 1 Then
                    subjectLine = subjectLine & tb.DataBodyRange.Cells (Nrow, tb.ListColumns("Order Number").Index)
                    lineCounter = lineCounter + 1
                    bodyline = "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
                Else:
                    subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index)
                    bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
                End If

                Set C = .FindNext(C)
            Loop While Not C Is Nothing And C.Address <> firstaddress
        End If
        Run SendMailFunction(emAddress, subjectLine, bodyline)
'                        Debug.Print vbNewLine
'                        Debug.Print emAddress
'                        Debug.Print "Subject: " & subjectLine
'                        Debug.Print "Body:" & vbNewLine; bodyline
    End With
goToNext:
Next I
Set C = Nothing
End Sub


Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
Dim I As Integer

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table10")

For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = emAddress
        .Subject = subjectLine
        .Body = "Hello, We require an update as to the following:" & DNL & bodyline _
              & DNL & _
                "Please Send an update as to the status of these line items " & _
                "providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
Next I

End Function

Generated Email

TABLE IMAGE

Welcome to SO. *IT does not work* does not really help us help. What does not work? What are you expecting to happen that is not happening? Please make it easier for us to help you. You may also prefer to loop through the `ListObject` directly, like in [here](http://stackoverflow.com/questions/12495678/how-do-i-loop-an-excel-2010-table-by-using-his-name-column-reference#12497229) — Scott Holtzman, May 09 '17 at 19:43
Sorry, Scott. Going line by line I get an error for the reference of the table. I believe I have it wrong. But I am unsure how to properly define it. — D.Mack, May 09 '17 at 19:51
Yes, Tim. Once that is commented out the above happens - Meant to writ this in the same comment but just learned that enter posts the comment. haha — D.Mack, May 09 '17 at 19:52
I would try to loop through the rows. It looks as though you might be looping through the columns. I'll try to put something together for you. — John Muggins, May 09 '17 at 20:27

John Muggins · Answer 1 · 2017-05-10T12:13:37.333

This works for me, given table name is "Table14"

Sub wserlkug()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")


For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
    Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
            .Subject = "Order # " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Order Number").Index)
            .Body = "Hello, We require an update as to the following:" & DNL & "Line #:  " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Line Number").Index) _
                  & DNL & _
                    "Please Send an update as to the status of these line items " & _
                    "providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
            .Send
        End With
        On Error GoTo 0
        Set OutMail = Nothing
Next i



End Sub

You can actually use the object variable "tb" instead of ActiveSheet.ListObjects("Table14").... I placed that there to show how to reference row and column in a table.

Thank you John! This works! Do you think an IF statement would catch the duplicate PO's and be able to include all line numbers for that Po on one email? — D.Mack, May 10 '17 at 12:46
Additionally, would adding a tblrange lookup, to find the name ensure that the file would always find the correct table name? — D.Mack, May 10 '17 at 12:59
I almost made a career out of that one! Can you go up to the answer and hit the top arrow key to make it the answer? I'll get points for that. — John Muggins, May 10 '17 at 19:54
haha seems like you could! its a great macro and functions just as I need it to! Thank you! Also I believe I did? I choose it as the answer and upvoted! — D.Mack, May 12 '17 at 15:37

John Muggins · Accepted Answer · 2017-05-10T19:19:45.940

The following code uses the email script as a function, which is called from the top macro. Please click on answer if this solves your problem

Sub findMethodINtable()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1

Set tb = ActiveSheet.ListObjects("Table14")


For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
    emAddress = tb.DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
    For x = LBound(myArray1) To UBound(myArray1)
        On Error Resume Next
        If emAddress = myArray1(x) Then GoTo goToNext
    Next x
        On Error GoTo 0
        subjectLine = "Order(s) # "
        ReDim Preserve myArray1(1 To nameCounter)
        myArray1(nameCounter) = emAddress
        nameCounter = nameCounter + 1
        lineCounter = 1
            With tb.ListColumns("Email Address").Range
                Set c = .Find(emAddress, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Beep
                    arrayCounter = arrayCounter + 1
                    Do
                        nRow = c.Row - 1
                        If lineCounter = 1 Then
                            subjectLine = subjectLine & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
                            lineCounter = lineCounter + 1
                            bodyline = "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
                        Else:
                            subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
                            bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ",  Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
                        End If

                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
                        Run SendMailFunction(emAddress, subjectLine, bodyline)
'                        Debug.Print vbNewLine
'                        Debug.Print emAddress
'                        Debug.Print "Subject: " & subjectLine
'                        Debug.Print "Body:" & vbNewLine; bodyline
            End With
goToNext:
Next i
Set c = Nothing
End Sub


Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String

NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")


    Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = emAddress
            .Subject = subjectLine
            .Body = "Hello, We require an update as to the following:" & DNL & bodyline _
                  & DNL & _
                    "Please Send an update as to the status of these line items " & _
                    "providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
            .Send
        End With
        On Error GoTo 0
        Set OutMail = Nothing



End Function

John, I keep getting defined varable errors, Each one I solve another pops up, the following are undefined (though I have defined most) i, x, c, firstaddress. — D.Mack, May 10 '17 at 17:02
I have gotten it to output an email. However it doesent appear to be using the data. See above for a picture — D.Mack, May 10 '17 at 18:11
Try it from a clean module without option explicit at the top. I usually don't take the time to define variables when I'm trying go hurry. Option explicit at the top of your module requires that all variables be 'dim'med in that module. Or you could take the time to dim all of the variables yourself. I did the hard part. — John Muggins, May 10 '17 at 18:18
First - Insert a new module without option explicit in it.. Copy both scripts again from above into it. Make sure that the sheet containing the table is the active sheet. Go to the VB editor, place the cursor somewhere inside findMethodINtable() and press PF5 to run it. If you still have problems then I'll help you debug it. — John Muggins, May 10 '17 at 18:27
When I say "both scripts" I mean the macro and the function in the last answer box only. — John Muggins, May 10 '17 at 18:29
This got it working, the email is beautiful. However it is opening a new email for each row, meaning multiples of the same email being opened with the exact same content. — D.Mack, May 10 '17 at 18:30
I thought it only created one duplicate per row, however it seems when run and left on its own rather then worked through slowly it creates, between 5 and 8 emails per row, all exact duplicates. — D.Mack, May 10 '17 at 18:44
I forgot to remove the "For I =" loop. I corrected the script above. Or simply remove the "for I =" line and the "next I" line from the function. That was causing it to loop through the email process several times. It should work now — John Muggins, May 10 '17 at 19:22

Emailing through Excel table

2 Answers2