My VBA Code is not working properly

[king0079z]

Dear all the VBA code is not working properly as it should send a reminder email if it checks there was "send Reminder" in the column to selected emails. The problem`s only working on row number one which contain " send "send Reminder" but another row no. Therefore I need your assistance in this issue

NO.	Project Description	Due Date l	Remarks	Email Address for the people who are responsible
1	Project 1	1/1/2020	Send Reminder	email1@outlook.com
2	Project 2	1/4/2020		email2@outlook.com
3	Project 3	1/1/2020	Send Reminder	email3@gmail.com
4	Project 4	1/1/2020	Send Reminder	email4@hotmail.com

The Code should send a reminder for all the email ist to the right if there is a send reminder in the remark column . Moreover, the project description should be included in the email subject and email body automatically
here is the code which I have written but it`s only working for Row 1 but I need it to work for all the rows in the worksheet.

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

 

[Peter Mac]

To start with with you are only creating one outlookmailitem

You need to create a mail item for each email.

I am not sure of the rest of your logic it seems to duplication's of the same or similar tests

 

[Peter Mac]

Heres what i came up with

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
Const mailcheck As String = "Send Reminder"
Dim mailchecktrue  As Boolean

Set OutLookApp = CreateObject("Outlook.application")


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


    If Cells(iCounter, 4).Offset(0, -1) = mailcheck Then
        Set OutLookMailItem = OutLookApp.CreateItem(0)
        With OutLookMailItem
            MailDest = Cells(iCounter, 4).Value
            .To = MailDest
            .Subject = Cells(iCounter, 1).Value
            .Body = "Reminder: Your next credit card payment is due. Please ignore if already paid." & Cells(iCounter, 1).Value
            .display
        End With
    End If
Next iCounter

Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
End Sub

 

[king0079z]

really thanks sir for your grate help


is it possible to end the email with a button without opening the outlook windows , so all the process can be from the excel

 

[Peter Mac]

change the .display to .send

 

[king0079z]

great thanks sir for your assistance I ran the code but for every sends reminder is needed to allow the permission as per the attached photo, is there is a way I can only do it once and I will go through the whole cells

 

[Lukasier]

Try with simple:
with Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
end with
Just turn in on again after code run

 

[king0079z]

where i need to add this code exactly after which line

 

[Lukasier]

Here you go:

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
Const mailcheck As String = "Send Reminder"
Dim mailchecktrue  As Boolean

with Application
.AskToUpdateLinks = False
.ScreenUpdating = False
.DisplayAlerts = False
end with 

Set OutLookApp = CreateObject("Outlook.application")


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


    If Cells(iCounter, 4).Offset(0, -1) = mailcheck Then
        Set OutLookMailItem = OutLookApp.CreateItem(0)
        With OutLookMailItem
            MailDest = Cells(iCounter, 4).Value
            .To = MailDest
            .Subject = Cells(iCounter, 1).Value
            .Body = "Reminder: Your next credit card payment is due. Please ignore if already paid." & Cells(iCounter, 1).Value
            .display
        End With
    End If
Next iCounter

Set OutLookMailItem = Nothing
Set OutLookApp = Nothing

with Application
.AskToUpdateLinks = True
.ScreenUpdating = True
.DisplayAlerts = True
end with 
End Sub

 

[king0079z]

unfortunately the code is not working