none
Creating an Automatic Tracking System Using Excel VBA RRS feed

  • Question

  • Dear All

    I wanted to ask your assistance to create a VBA code that has the capability to make  An Automatic  Tracking System Using Excel VBA. Since I am still new at the VBA Code I have managed with a help of my friend to create a system which checking if there is a "Send Reminder" Massage ( As per the below image ) it will directly send an email reminder to a certain user from the listed email if the due date met with today date. What I need to do is to make the due change according to a certain value from a specific sender and according to this value, the due date will change either 1, 2 or 3 days according to the type of the value.  and after the whole loop will start again to send a reminder email to a certain mail from the list.

    My VBA CODE is 

    Sub SendReminderMail()

    Dim OutLookApp As Object

    Dim OutLookMailItem As Object

    Dim iCounter As Integer

    Dim iCounter2 As Integer

    Dim MailDest As String

    Dim Subj As String

    Set OutLookApp = CreateObject("Outlook.application")

    Set OutLookMailItem = OutLookApp.CreateItem(0)

    With OutLookMailItem

    MailDest = ""

    Subj = ""

    For iCounter = 1 To WorksheetFunction.CountA(Columns(4))

    If MailDest = "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then

    MailDest = Cells(iCounter, 4).Value

    ElseIf MailDest <> "" And Cells(iCounter, 4).Offset(0, -1) = "Send Reminder" Then

    MailDest = MailDest & ";" & Cells(iCounter, 4).Value

    End If

    Next iCounter

    For iCounter2 = 1 To WorksheetFunction.CountA(Columns(4))

    If Subj = "" And Cells(iCounter2, 4).Offset(0, -1) = "Send Reminder" Then

    Subj = Cells(iCounter2, 1).Value

    End If

    Next iCounter2

    .BCC = MailDest

    .Subject = Subj

    .Body = "Reminder: Your next credit card payment is due. Please ignore if already paid." & Subj

    .Send

    End With

    Set OutLookMailItem = Nothing

    Set OutLookApp = Nothing

    End Sub

    Saturday, January 11, 2020 8:22 AM