Emailing through Excel table - vba

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

Answer 1

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

Answer 2

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.