Use VBA in Excel to add automatic 2 week reminder from start date in Outlook

Hi

Id like to add a 2 week reminder (20160 minutes) into this code onlt if there is a date in the start column (col 9). Is this at all possible. Ive tried adding a default 20160 value in The reminder column of my spreadsheet but its add reminders to all 268 rows. Thanks in advance

Private Sub CommandButton1_Click()
If Not ThisWorkbook.Name = "LD TOOL v2.xlsm" Then
' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 5
    r = 6
Application.ScreenUpdating = False
    Do Until Trim(Cells(r, 1).Value) = ""
        ' Create the AppointmentItem
        Set myApt = myOutlook.createitem(1)
        ' Set the appointment properties
        myApt.Subject = Cells(r, 1).Value
        myApt.Start = Cells(r, 9).Value
        myApt.Location = Cells(r, 10).Value
        myApt.Duration = Cells(r, 11).Value
        ' If Busy Status is not specified, default to 2 (Busy)
        If Trim(Cells(r, 12).Value) = "" Then
            myApt.BusyStatus = 2
        Else
            myApt.BusyStatus = Cells(r, 12).Value
        End If
        If Cells(r, 13).Value > 0 Then
            myApt.ReminderSet = True
            myApt.ReminderMinutesBeforeStart = Cells(r, 13).Value
        Else
            myApt.ReminderSet = False
        End If
        myApt.Body = Cells(r, 14).Value
        myApt.Save
        r = r + 1
    Loop
    Application.ScreenUpdating = True
End If
End Sub

Regards

SB

Maybe:

Option Explicit

Private Sub CommandButton1_Click()
If Not ThisWorkbook.Name = "LD TOOL v2.xlsm" Then
' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 5
    r = 6
Application.ScreenUpdating = False
    Do Until Trim(Cells(r, 1).Value) = ""
        If Cells(r, 9).Value <> "" Then
            ' Create the AppointmentItem
            Set myApt = myOutlook.createitem(1)
            ' Set the appointment properties
            myApt.Subject = Cells(r, 1).Value
            myApt.Start = Cells(r, 9).Value
            myApt.Location = Cells(r, 10).Value
            myApt.Duration = Cells(r, 11).Value
            ' If Busy Status is not specified, default to 2 (Busy)
            If Trim(Cells(r, 12).Value) = "" Then
                myApt.BusyStatus = 2
            Else
                myApt.BusyStatus = Cells(r, 12).Value
            End If
            If Cells(r, 13).Value > 0 Then
                myApt.ReminderSet = True
                myApt.ReminderMinutesBeforeStart = Cells(r, 13).Value
            Else
                myApt.ReminderSet = False
            End If
            myApt.Body = Cells(r, 14).Value
            myApt.Save
            r = r + 1
        End If  'Cells(r, 9).Value <> ""
    Loop    'Trim(Cells(r, 1).Value) = ""
    Application.ScreenUpdating = True
End If
End Sub

Regards, TMS

Yes, my fault. Move the End If up a row, before the line that says r = r + 1.

Sorry.

Regards, TMS

Hi TMS,

Thats great. Do I add the defalt time in this line? (Im a relative vba newbie but getting there)

If Cells(r, 9).Value <> "" Then