Realghostwheel
New Member
- Joined
- Apr 1, 2022
- Messages
- 2
- Office Version
- 365
- Platform
- Windows
Trying to set an auto email option for a large excel sheet, When I place a X in column 8 it generates an email and places a emailed note into column 11. I keep getting repeats for each X in column 8 though, Trying to set the script to also review that Column 11 has data, so that it only sends an email if Column 8 has an X and Column 11 is blank. Keep getting errors though.
For i = 1 To lRow
If (Cells(i, 8)) <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
The above works to send the email but when trying to compare column 11 to ensure that it is blank is not working.
Option Explicit
Sub Email1()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim Sheets As Worksheet
Dim OutApp, OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
lRow = Cells(Rows.Count, 8).End(xlUp).Row
For i = 1 To lRow
If (Cells(i, 8)) <> "" Then '<--------------------------------------------- change this range
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 9) 'gets the recipient from col I
eSubject = "Contract Review"
eBody = "Hello" & "," & vbNewLine & vbNewLine & _
"A new PO has been entered and is ready for review PO " & Cells(i, 5) & vbNewLine & vbNewLine & _
"Sincerely, "
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.Display ' ********* Creates draft emails. Comment this out when you are ready
'.Send '********** UN-comment this when you are ready to go live
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 11) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column 11"
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
For i = 1 To lRow
If (Cells(i, 8)) <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
The above works to send the email but when trying to compare column 11 to ensure that it is blank is not working.
Option Explicit
Sub Email1()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim Sheets As Worksheet
Dim OutApp, OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
lRow = Cells(Rows.Count, 8).End(xlUp).Row
For i = 1 To lRow
If (Cells(i, 8)) <> "" Then '<--------------------------------------------- change this range
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 9) 'gets the recipient from col I
eSubject = "Contract Review"
eBody = "Hello" & "," & vbNewLine & vbNewLine & _
"A new PO has been entered and is ready for review PO " & Cells(i, 5) & vbNewLine & vbNewLine & _
"Sincerely, "
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.Display ' ********* Creates draft emails. Comment this out when you are ready
'.Send '********** UN-comment this when you are ready to go live
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 11) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column 11"
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub