Outlook appointment as data is entered

[asdsparky]

Ok guys, I'm reaching again...
I have a spreadsheet that I need to initiate an outlook calendar event/ reminder for 25 days after the date entered. Through much research and trial & error, I have a VBA code written that almost does what I need. I just need some assistance in tweaking it a bit. This code does add entries to my calendar as written but not all of what I need (see below). Thanks in advance for any light you can shed.

What I need:
1. After I enter data into a row to include a date in column B, I need the code to run. This is probably best if I run upon saving or closing the workbook so I don't accidentally send the calendar event without entering all of the data for the day. Right now the code only runs when I manually initiate it.
2. I need the code to add events only for new data entered each time I save/close. I do not need repeat entries each time I save.
3. I would love for the entries to go into a specific calendar (Labeled "Personal") other than my default, but I can tackle that another time.

Here's my current code:

Option Explicit
Private Sub CreateAppointment()
    ' adds a list of appontments to the Calendar in Outlook
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
    
         
    On Error Resume Next
    Worksheets("17-18 MMRRF").Activate
 
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    
    
    r = 6  ' first row with appointment data in the active worksheet
    Dim mysub, myStart, myEnd
    While Len(Cells(r, 2).Text) <> 0
        mysub = "MMRRF" & Cells(r, 3) & "Response Due"
        myStart = DateValue(Cells(r, 2).Value + 25)
        myEnd = DateValue(Cells(r, 2).Value + 25)
       'DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
            ' set default appointment values
            .Location = "MMRRF"
            .Body = "Response Due in 5 days"
            .ReminderSet = True
            .BusyStatus = olFree
            '.RequiredAttendees = "Myname@mailserver.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = "MM Response due in 5 Days" & " - " & Cells(r, 3)
            .Location = "MMRRF"
            .Body = .Subject
            .ReminderSet = True
            .BusyStatus = olBusy
            .Categories = "Important Event"
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
          
        End With
     r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olApp = Nothing
End Sub

Also, right now, when I run the code, I only get entries from the data in rows 6 and 7. I tried to add these lines to the code but I ended up with a loop that wouldn't stop adding the first entry continuously. I literally deleted over 200 calendar entries of just Row 6.

Private Sub CreateAppointment()
    ' adds a list of appontments to the Calendar in Outlook
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long    
        
    '.....
        
    End If
    End If
    
[COLOR=#ff0000]     For r = 6 To 300  [/COLOR]'(I don't have 300 rows but wanted to cover it just in case. Would rather do auto count to last row but couldn't get that to work either.)
    Dim mysub, myStart, myEnd
    While Len(Cells(r, 2).Text) <> 0

    '.....    
    
        End With
    Wend
[COLOR=#ff0000]    Next r[/COLOR]
    Set olAppItem = Nothing
    Set olApp = Nothing
End Sub

I also tried This but nothing at all happened:

Private Sub CreateAppointment()
    ' adds a list of appontments to the Calendar in Outlook
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
[COLOR=#ff0000]    Dim lr As Long[/COLOR]
    
        
    '.....
    
    
    End If
    End If
    
[COLOR=#ff0000]    lr = Cells(Rows.Count, 2).End(xlUp).Row[/COLOR]
[COLOR=#ff0000]    For r = 6 To lr  [/COLOR]'(I don't have 300 rows but wanted to cover it just in case. Would rather do auto count to last row but couldn't get that to work either.)
    Dim mysub, myStart, myEnd
    While Len(Cells(r, 2).Text) <> 0

    '.....
    
    
    
        End With
    Wend
[COLOR=#ff0000]    Next r[/COLOR]
    Set olAppItem = Nothing
    Set olApp = Nothing
End Sub

 

[Jerry Sullivan]

Hi asdsparky,

We use a process similar to what you are attempting to create calendar items from an Excel worksheet that tracks project data including upcoming milestones. Since milestones often change or are canceled, we found it more effective to clear all the appointment items from the calendar, then create all new items from the list in Excel, instead of trying to keep track of/update only those that change.

That process works for us because the Excel entry form is only means we use for making entries for this shared calendar. Would that work for you, or do you need it to work along with appointment items entered manually?

I'd be glad to help with your specific coding questions, but it will be easier to suggest code knowing whether you want to try this approach.

 

[asdsparky]

I won't be able to clear the calendar each time I need to add data to the spreadsheet unless I create a separate calendar strictly for these reminders. I have 14 people adding appointments on a regular basis and this spreadsheet is just one means of entry. I won't be adding to this spreadsheet daily either. I may add two or three separate entries at once then it may be 3 weeks to a month before I add more. The vba code will likely need to check the calendar for existing entries. The goal of this is basically when I enter a row of data into the spreadsheet, I have 30 days to review and respond. I want a reminder set for day 25 to let me know that the deadline is approaching. The dates/ milestones will not change as the dates entered are the dates the requests are received by my office.

 

[Jerry Sullivan]

Okay- I understand.

Two relatively simple options for updating any new items when you save the workbook are:

1. Add an "Uploaded" field to your workbook. Each time the workbook is saved, an event procedure can check and upload any entries that don't have "yes" in this field. After uploading, the procedure will populate this field with "yes".

2. If you don't want to add a field, the workbook could store the row number of the last item uploaded. This is a little less robust since it assumes you won't delete rows.

Do you have a preference?

 

[asdsparky]

Less robust sounds good. Once entered and saved, I will not be deleting rows. I will only add new rows as new data needs to be entered.

 

[Jerry Sullivan]

Here is some code you can try.

First create a Range Named "LastCreatedAppointment" that refers to the date cell (column B) of the last appointment item that has already been created in the Outlook Calendar. This would be cell B5 if you are running this for the first time and your first item to create is on Row 6.

Paste in the ThisWorkbook Code Module:

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 '--checks to see if any new appointments have been added to the appointment list
 '    since the last save. If so, calls procedure to create new appoinments in
 '    an Outlook calendar.
 '--uses a named range with workbook scope to store a reference to the date cell
 '    of the last created appointment.
 
 Dim rCurrentLastApptDate As Range, rSavedLastApptDate As Range
 
 On Error GoTo ErrProc
 gsErrMsg = vbNullString
  
 Application.EnableCancelKey = xlErrorHandler
 Application.EnableEvents = False
 
 '--check if any new appointments since last update
 Set rSavedLastApptDate = ThisWorkbook.Names( _
   "LastCreatedAppointment").RefersToRange
 
 With rSavedLastApptDate
    Set rCurrentLastApptDate = .Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp)
    If rCurrentLastApptDate.Row > .Row Then
      Call CreateAppoinments( _
         rDates:=Range(.Offset(1), rCurrentLastApptDate))
      
      '--if no errors, update last appt reference
      If Len(gsErrMsg) = 0 Then
         ThisWorkbook.Names( _
            "LastCreatedAppointment").RefersTo = rCurrentLastApptDate
      End If
    End If
 End With

ExitProc:
 On Error Resume Next
 Application.EnableEvents = True
 If Len(gsErrMsg) Then MsgBox gsErrMsg
 gsErrMsg = vbNullString
 Exit Sub

ErrProc:
 gsErrMsg = Err.Number & ": " & Err.Description
 Resume ExitProc
End Sub

Paste into a Standard Code Module (like Module1):

Option Explicit
Option Private Module

Public gsErrMsg As String

Sub CreateAppoinments(rDates As Range)
'--adds a list of appointments to the Calendar in Outlook
 
 Dim dtMyStart As Date, dtMyEnd As Date
 Dim olApp As Outlook.Application
 Dim olAppItem As Outlook.AppointmentItem
 Dim rDate As Range
 Dim sMySub As String
 
 '--test for open instance of Outlook
 On Error Resume Next
 Set olApp = GetObject("", "Outlook.Application")
 On Error GoTo 0
 
 '--if no open instance, create one
 If olApp Is Nothing Then
   On Error Resume Next
   Set olApp = New Outlook.Application
   On Error GoTo 0
   
   If olApp Is Nothing Then
      gsErrMsg = "Outlook is not available!"
      GoTo ExitProc
   End If
 End If
    
 For Each rDate In rDates
   sMySub = "MMRRF" & rDate.Offset(0, 1).Value & "Response Due"
     'or?   "MM Response due in 5 Days" & " - " & rDate.Offset(0, 1).Value
   dtMyStart = rDate.Value + 25
   dtMyEnd = dtMyStart
   
   '--creates a new appointment
   Set olAppItem = olApp.CreateItem(olAppointmentItem)
   With olAppItem
     ' set default appointment values
      .Location = "MMRRF"
      .Body = "Response Due in 5 days"
      .ReminderSet = True
      .BusyStatus = olFree
     '.RequiredAttendees = "Myname@mailserver.com"
      On Error Resume Next
      .Start = dtMyStart
      .End = dtMyEnd
      .Subject = sMySub
      .Location = "MMRRF"
      .Body = .Subject
      .ReminderSet = True
      .BusyStatus = olBusy
      .Categories = "Important Event"
      On Error GoTo 0
     .Save ' saves the new appointment to the specified folder
   End With
 Next rDate
 
ExitProc:
 Set olAppItem = Nothing
 Set olApp = Nothing
End Sub