Editing VBA that uses tables to generate email

[hooper12345]

Hello all,

I believe long ago I found on this forum a very helpful VBA code for sending an automatic email from data that was contain in a table structure in excel. I would like to use the same characteristics (i.e: referencing data from certain rows and based off expiring dates) but I no longer need the data to be in a table. Every change I make to eliminate the need for the table, VBA flag it.

I've added the example code I found prior to my manipulating. Any help/tips are greatly appreciated!




Sub sendSpillEmails()

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

'Turn OFF any filters..
ActiveSheet.ListObjects("Table1").ShowAutoFilter = False

'Define shortcut for Table..
Set zTable = ActiveSheet.ListObjects("Table1").Range

'Apply filter for blanks in column [H]..
zTable.AutoFilter Field:=[H1].Column, Criteria1:="="

'Define shortcut for filtered column [A]..
Set zRangeA = zTable.Resize(, 1).SpecialCells(xlCellTypeVisible)
zCount = zRangeA.Cells.Count - 1 '-1 = ignore header row

If zCount = 0 Then 'no blanks found in column [H]
zTable.AutoFilter 'turn Table filters back ON
Exit Sub 'nothing else to do
End If 'end of test for no blanks

Set OutApp = CreateObject("Outlook.Application")

For Each zCell In zRangeA 'loop through all filtered cells in column [A]
zRow = zCell.Row 'row number for filtered record

zEmail = Cells(zRow, "A") 'fetch email address from column [A]

If zEmail Like "*@*" Then 'cell contains an email address, so..
zDate = Cells(zRow, "B") 'fetch Date from column
zTerm = Cells(zRow, "C") 'fetch Terminal from column [C]
zPRO = Cells(zRow, "D") 'fetch Tracking# from column [D]
zFile = Cells(zRow, "G") 'fetch File# from column [G]

'PREPARE EMAIL BODY TEXT..
strbody = ""
strbody = strbody & zTerm & " Manager,"
strbody = strbody & vbCr & vbCr
strbody = strbody & zTerm & " currently has spill for which no corrective action has been completed. The "
strbody = strbody & "general details of the spill are below:" & vbCr
strbody = strbody & " Spill Date: " & zDate & vbCr
strbody = strbody & " Tracking Number: " & zPRO & vbCr
strbody = strbody & " Spill File: 20" & zFile & vbCr & vbCr
strbody = strbody & "Additional details on the spill can be found on the common server at "
strbody = strbody & "<\\xyzServer\Common\Environmental\2015 Spill Files\March 2015>" & vbCr
strbody = strbody & "Please follow up appropriately and complete the CAP located here: <\\xyzServer\Common\Corrective Action Hazmat Spills\March 2015>"
strbody = strbody & vbCr & vbCr & "Thanks"

Set OutMail = OutApp.CreateItem(0)

zDone = zDone + 1 'increment counter
saywhat = "processing record " & zDone & " of " & zCount 'update progress message
Application.StatusBar = saywhat 'show progress message

On Error Resume Next 'set error trapping
With OutMail
.To = zEmail '<< use EMAIL ADDRESS FROM COLUMN A
.CC = ""
.BCC = ""
.Subject = zTerm & " incomplete corrective action" '<< SUBJECT LINE
.Body = strbody
'.Attachments.Add ("C:\test.txt") '<< You can also add a file like this
'.Send '<< or use .Display
.Display
End With

Cells(zRow, "I") = "email sent: " & Format(Date, "dd-mmm-yyyy") '<<change format as required

End If 'end of test for email found for empty spill
Next 'process next filtered record

On Error GoTo 0 'reset error trap
Application.StatusBar = "" 'clear and reset bottom statusbar

Set OutMail = Nothing 'tidy up (if you must)
Set OutApp = Nothing 'tidy up (if you must)

End Sub