VBA : Automatic Email when a value on a cell changes

[sevenpott]

The main purpose of the following code is to Send a reminder as an email if TODAY + 60 > Deadline meaning that i need to get a reminder 2 months ahead of an expiring fixed contract of a vessel and take the names of the vessels that make my formula TRUE as 'Send Reminder' and forward only the names of the vessels on Column A to an email. I want this to run once a week but i need to make it run automatically when i open excel.
I made the following code to send an email via macro which works the way i want it. Not that much familiar with VBA.

Sub SendReminderMail()
Dim OutApp As Object
Dim OutMail As Object
Dim no_vessels As Integer, vessel_name() As String, Formula() As String
Dim count As Integer, i As Integer, k As Integer, temp As Integer
Dim indicator() As Integer, names_to_send() As String
Dim rng As Range
Dim sCC As String, sSubj As String, sEmAdd As String






'// Change No_vessels to match excel count -1
no_vessels = 18


ReDim vessel_name(no_vessels, 1), Formula(no_vessels, 1)


For i = 2 To (no_vessels + 1)
    vessel_name(i - 1, 1) = Cells(i, "A")
    Formula(i - 1, 1) = Cells(i, "D")
Next i


count = 0
For i = 1 To no_vessels
    If Formula(i, 1) = "Send Reminder" Then
        count = count + 1
    End If
Next i


k = 1
ReDim indicator(count, 1)
For i = 1 To no_vessels
    If Formula(i, 1) = "Send Reminder" Then
        indicator(k, 1) = i
        k = k + 1
    End If
Next i


ReDim names_to_send(count, 1)


For i = 1 To count
    temp = indicator(i, 1)
    names_to_send(i, 1) = vessel_name(temp, 1)
Next i
'// change for output cell for email
Range("F1").Activate
r = ActiveCell.Row
c = ActiveCell.Column


For i = 1 To count
    Cells(i, c).Value = names_to_send(i, 1)
Next i


'// Change the values of these variables to suit
sEmAdd = "panos.kwstopoulos@gmail.com"
sCC = ""
sSubj = "ATTENTION on fixtures expiring"
    
Set rng = Nothing
On Error Resume Next
Set rng = Range("F1:F" & count)
On Error GoTo 0


With Application
    .EnableEvents = 0
    .ScreenUpdating = 0
    .Calculation = xlCalculationManual
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
    .To = sEmAdd
    .CC = sCC
    .Subject = sSubj
    .HTMLBody = "Dear 360, " & _
    "Please find below list of vessels with expring fixtures" & _
    RangetoHTML(rng) & _
    "Thank you"
    .Send '// Change this to .Display if you want to view the email before sending.
End With
On Error GoTo 0


With Application
    .EnableEvents = 1
    .Calculation = xlCalculationAutomatic
End With
Set OutMail = Nothing: Set OutApp = Nothing


End Sub

 

[DanteAmor]

Put the following macro in the events of your Workbook.


It will run only on Mondays when you open the file.
If you open the file several times on Monday, it will only run the first time.
If you did not open the file on a Monday, it will run once the next day you open it.


Create a sheet called "Temp", you can hide it if you want.

Private Sub Workbook_Open()
    wday = 1 'Weekday(Date, vbMonday)
    If wday > 1 Then
        If Sheets("temp").Range("A1").Value = "" Then
            Call SendReminderMail
            Sheets("temp").Range("A1").Value = Date
        Else
            If Sheets("temp").Range("A1").Value <> (fecha - wday) + 1 Then
                Call SendReminderMail
                Sheets("temp").Range("A1").Value = Date
            End If
        End If
    Else
        If Sheets("temp").Range("A1").Value = "" Then
            Call SendReminderMail
            Sheets("temp").Range("A1").Value = Date
        Else
            If Sheets("temp").Range("A1").Value = Date Then
            Else
                Call SendReminderMail
                Sheets("temp").Range("A1").Value = Date
            End If
        End If
    End If
End Sub

ThisWorkbook EVENT
- Open the VB Editor (press Alt + F11).
- Over in the Project Explorer, double click on ThisWorkbook.
- In the white panel that then appears, paste the previous code.

 

[sevenpott]

Thank you. I ll check it and reply back for feedback! cheers

 

[DanteAmor]

Okay, let me know if you have any doubts