Schedule email from list

[theboyscout]

Hello,

I'm trying to create a script that would search a folder, find the last inserted spreadsheet, locate a field and if that field is > 0 send an email. And this is to be run weekly.

F	L	O
Descr	Email	Available_Spots
60749	jon.snow@got.com	1

<tbody>
</tbody>

I've scraped up a number of scripts from other users (unfortunately, I can't remember profile names to give them credit), see

below​

:

Sub Waitlist_Email()

Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
Dim OutApp As Object
Dim OutMail As Object
Dim strbody, SigString, Signature As String
Dim MailAttachments As String
Dim cell As Variant
Dim GetBoiler As Object

'Search for recent file in folder
MyPath = “C:\Users\Desktop\Waitlist"
If Right(MyPath, 1) <> “ \ ” Then MyPath = MyPath & “ \ ”
MyFile = Dir(MyPath & “ * .xls”, vbNormal)
If Len(MyFile) = 0 Then
MsgBox “No files were found…”, vbExclamation
Exit Sub
End If
Do While Len(MyFile) > 0
LMD = FileDateTime(MyPath & MyFile)
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
Workbooks.Open MyPath & LatestFile

'If file is located send email
Sheets("Sheet1").Select
Range("A1").Select

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

'On Error GoTo cleanup
For Each cell In Columns("L").Cells
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "O").Value) > "0" Then

With Application.ActiveSheet
MailAttachments = Cells(cell.Row, "E").Value
End With


Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

With OutMail

.To = cell.Value
.Subject = "Enrollment available " & Cells(cell.Row, "F").Value 'Refer value from column F (Course Description)
.HTMLBody = "" & _
"Hello ," & Cells(cell.Row, "H") & ", " & ""
" & _
"Blah blah blah " & Cells(cell.Row, "F") & " blah blah blah " & Cells(cell.Row, "K") & " blah blah blah. " & ""
" & _
"
" & _
"
" & _
"
" & _
"**************************************************************************************************************" & "
" & _
"This is your signature file. It will always be 7 rows below whatever text you add in the macro code."
'To add another line in your message or signature without skipping a row, end the line of text with
'a quotation symbol and then an ampersand and an underscore. Ex: end of text." & _
'.Attachments.Add MailAttachments
.Display
'Or use .Send

End With

On Error GoTo 0
End If
Next
cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True

End Sub

I'm getting error message at

" & _​

<strike></strike> and I can't figure out how to schedule to run weekly.

Any help would be appreciated

 

[Logit]

.
Once the macro has opened the newest file, what sheet and cell are you looking at for a value ?

And, what value are you expecting in that cell, which will initiate the email sending ?

 

[theboyscout]

It'll be Sheet1 and the cell I'll be looking at for a value is O. For each instance that in cell O there is a value greater than 0 then send an email

 

[Logit]

.
This is part of the code :

Option Explicit


Sub send_email_via_outlook()


' Tools - Refrence - Microsoft Outlook
Dim olApp As New Outlook.Application
Dim olMail As MailItem


Set olMail = olApp.CreateItem(olMailItem)
    
    With olMail
        .To = "test@gmail.com"
        .CC = ""
        .Subject = "Send Range as table in outlook"  '<br> used to insert a line ( press enter)
        .HTMLBody = "Please find the table below <br><br> " & _
                    create_table(Sheet2.Range("A1").CurrentRegion) & _
                    "</Table><br> <br>Regards,<br><br>Afred E. Newman"
        .Display
        '.Send
    End With




End Sub


Function create_table(rng As Range) As String


Dim mbody As String
Dim mbody1  As String
Dim i As Long
Dim j As Long


mbody = "<TABLE width=""75%"" Border=""1"", Cellspacing=""0""><TR>" ' configure the table


'create Header row
For i = 1 To rng.Columns.Count
    mbody = mbody & "<TD width=""100"", Bgcolor=""#A52A2A"", Align=""Center""><Font Color=#FFFFFF><b><p style=""font-size:18px"">" & rng.Cells(1, i).Value & " </p></Font></TD>"
Next


' add data to the table
For i = 2 To rng.Rows.Count
    mbody = mbody & "<TR>"
    mbody1 = ""
    For j = 1 To rng.Columns.Count
    mbody1 = mbody1 & "<TD><center>" & rng.Cells(i, j).Value & "</TD>"
    Next
    mbody = mbody & mbody1 & "</TR>"
Next


create_table = mbody
End Function

Examine the download to view the remainder of the code.

Download workbook : https://www.amazon.com/clouddrive/share/2lC7Pk8bPRflJxyOnSkP16urmcqMy4r4DEHsj54m7XP

 

[theboyscout]

Hello Logit,

Thanks for your response. Unfortunately, your script doesn't accomplish what I'm looking to do.

I'll elaborate on what I'm trying to get done.

Below is a sample of the spreadsheet that will be generated on a weekly basis. It contains the names and email addresses of people on a waitlist for a course(s). What I'm trying to do is have a script that would run on a schedule and check the last updated spreadsheet in the folder (Waitlist), search the sheet and locate column O. In column O if there is a value greater than 0 I would like an individual email to be sent to each person's email address (column L) notifying them there's a spot available.

A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
Year	Sess	Cat	Sec	Nbr	Descr	ID	Name	Action	Requestor	Date	Email	Cap	Total	Avail	Position
2019	1	738	A	60749	History 1000	124919713	Tora Willett	Enr	Tora Willett​	11/19/2018 4:35:09 PM	Tora.Willett@hotmail.com	32	32	0	1
2019​	1	751	1	60811	Business Policy (BPL) 5100	118275089	Codi Gruner	Enr	Codi Gruner​	12/14/2018 11:49:50 AM	Codi.Gruner@aol.com	39	38	1	1
2019​	1	7572	1	60738	Business 9100	189572396	Carmine Paz	Enr	Carmine Paz​	11/19/2018 4:40:24 PM	Carmine.Paz@gmail.com	25	24	1	1
2019​	2	704	1	60755	History 1003	186625577	Audry Fentress	Enr	Audry Fentress​	11/20/2018 4:40:24 PM	Audry.Fentress@hotmail.com	11	8	3	1
2019​	3	705	1	60749	Statistics 1001	228457190	Tu Winborne	Enr	Tu Winborne​	11/21/2018 4:40:24 PM	Tu.Winborne@gmail.com	32	31	1	1

Thanks in advance

 

[Logit]

.
I believe this will accomplish the goal. Note the spelling of folders, workbooks and worksheets in the code. Make certain your names match
those in the code.

Download workbook : https://www.amazon.com/clouddrive/share/dFs5x1jGz9A7z75klHSybYSfILHJj2RmYQE4bwZerVO

Option Explicit


Sub OpenLatestFile()


    'Declare the variables
    Dim MyPath As String
    Dim MyFile As String
    Dim LatestFile As String
    Dim LatestDate As Date
    Dim LMD As Date
    
    'Specify the path to the folder
    MyPath = Environ("USERPROFILE") & "\Desktop\WaitList\"
    
    'Make sure that the path ends in a backslash
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
    
    'Get the first Excel file from the folder
    MyFile = Dir(MyPath & "*.xlsx", vbNormal)
    
    'If no files were found, exit the sub
    If Len(MyFile) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    
    'Loop through each Excel file in the folder
    Do While Len(MyFile) > 0
    
        'Assign the date/time of the current file to a variable
        LMD = FileDateTime(MyPath & MyFile)
        
        'If the date/time of the current file is greater than the latest
        'recorded date, assign its filename and date/time to variables
        If LMD > LatestDate Then
            LatestFile = MyFile
            LatestDate = LMD
        End If
        
        'Get the next Excel file from the folder
        MyFile = Dir
   Loop
   
   Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet


    Application.ScreenUpdating = False
    Set wb1 = ThisWorkbook
    Set wb2 = Workbooks.Open(MyPath & LatestFile)
    Set ws1Format = wb1.Sheets("Sheet2")
    Set ws2Format = wb2.Sheets("Sheet1")


    '' Copy the cells of the "Sheet1" worksheet.
    ws2Format.Cells.Copy wb1.Sheets("Sheet2").Range("A1")


    wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
    Application.ScreenUpdating = True
   
    eMail
    
    Sheets("Sheet2").UsedRange.ClearContents
    
End Sub


Sub eMail()
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 OutApp, OutMail As Object
Dim FullIdNo As String
Dim strFilename As String


With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With


Sheet2.Select
lRow = Cells(Rows.Count, 15).End(xlUp).Row
For i = 2 To lRow
    If Cells(i, 15).Value > 0 Then
         Set OutApp = CreateObject("Outlook.Application")
         Set OutMail = OutApp.CreateItem(0)
    
            toList = Cells(i, 8)   'gets the recipient email address from col X
            eSubject = "Enrollment available : " & Cells(i, 6).Value 'Refer value from column G (Course Description)
            eBody = "Dear " & Cells(i, 8) & " : " & vbCrLf & vbCrLf & "Just a quick note to advise " & Cells(i, 6) & " Class enrollment is available." & vbCrLf & vbCrLf & _
            "Sincerely, " & vbCrLf & vbCrLf & _
            "Your Signature"
            
            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
        
    End If
Next i


On Error GoTo 0
        Set OutMail = Nothing
        Set OutApp = Nothing


Application.Goto ActiveWorkbook.Sheets("Sheet1").Range("A1")


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

 

[Logit]

.
theboyscout

Did the code work for you ?