VBA Multiple body text references creating multiple emails - Help!

[LucyLucy]

Sheet contains an index of descriptions and order dates:
Column D = Roof materials
Column E = 12-09-2019

Below is to check order date in Column E and match to todays date.

Checks to see if "Reminder Sent" is in Column F, if not, creates emails and places "Reminder Sent" with date/time in Columns F & G.

Email generated with the intro text, to, etc and embed Column D into body - all happy and fluffy...

...Gots a problem though - and it's driving me completely bananas...and someone might be able to spot it (please!!)

If there's 3 matches in Column E, there'll be 3 emails generated: the first - embedding the first match, the second - embedding the first and the second match, and the third - embedding the first, second and third match.

Oh God, please help me stop it doing this loop...I'm not fussed at all on whether it keeps generating 3 emails with 3 separate references or if I can condense it into one...but I'm pulling my eyeballs out over what it's doing right now.

Can anyone spot where it is in the below?

Thanks so much in advance, genuinely appreciate it.


Private Sub Workbook_Open()
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim sSendTo As String
Dim sSendCC As String
Dim sSendBCC As String
Dim sSubject As String
Dim sTemp As String


Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon


sSendTo = "whoeverisorderthings.com"
sSendCC = "listofpeople.com"
sSendBCC = "Johnsemailarchive.com"
sSubject = "Automatic ODA (Order Date Alert) from the Onsite Trade Schedule"


lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 2 To lLastRow
If Cells(lRow, 6) <> "Reminder Sent" Then
If Cells(lRow, 5) <= Date Then
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = sSendTo
If sSendCC > "" Then .CC = sSendCC
If sSendBCC > "" Then .BCC = sSendBCC
.Subject = sSubject


sTemp = sTemp & "This is an automated ODA from the Onsite Trade Schedude." & vbCrLf & vbCrLf & "The order date for the following materials has been scheduled for today, please confirm:" & vbCrLf & vbCrLf
sTemp = sTemp & " " & Cells(lRow, 4) & vbCrLf
.Body = sTemp
.Display
End With
Set OutMail = Nothing


Cells(lRow, 6) = "Reminder Sent"
Cells(lRow, 7) = Now()
End If
End If
Next lRow
Set OutApp = Nothing
End Sub

 

[starl]

You're looping through all the rows. Every line with sTemp - you are including the previous value of sTemp to add to the text.... get it?

I don't see *why* a new email would want the previous sTemp text, so change this line:

Original:                
sTemp = sTemp & "This is an automated ODA from the Onsite Trade Schedude." & vbCrLf & vbCrLf & "The order date for the following materials has been scheduled for today, please confirm:" & vbCrLf & vbCrLf
New:
sTemp = "This is an automated ODA from the Onsite Trade Schedude." & vbCrLf & vbCrLf & "The order date for the following materials has been scheduled for today, please confirm:" & vbCrLf & vbCrLf