Create appointment

[Guest]

A couple of weeks ago I send an email asking for code to automatically set an
appointment in my calendar depending on the date in a certain cell. I want to
be reminded when a certain date arrives and I need to take an action. Bernie
was kind enough to send me the following code.

Sub CreateOutlookAppointments()
Dim OL As Object
Dim myAppt As Outlook.AppointmentItem
Dim myCell As Range

Set OL = CreateObject("outlook.application")

For Each myCell In Activesheet.Range("B1:B10")
If myCell(1,2).Value <> "Appointment added" Then
Set myAppt = OL.CreateItem(olAppointmentItem)
With myAppt
..Body = "An important reminder"
..Start = myCell.Value + 8 / 24
..Subject = "This is an important reminder"
..Save
End With
myCell(1,2).Value = "Appointment added"
End If
Next myCell

End Sub

This works but there is a problem, it will add an appointment for all the
cells in the range B1:B10, even if there is no date in the range. How would I
adapt this code so that say for example I entered a certain date in a cell
and I wanted to be reminded to take an action one week prior to the actual
date in the cell. Could I set up the maco so that I could run the macro just
on the cell that I entered the date into. That way as I enter dates I can run
the macro just for that cell. All the dates won't be entered at the same time
so I really won't know the range.

Thanks very much for any help. I am using Excel 2003.

Best regards,

Dee

 

[Guest]

You may have to play with this for awhile but it should give you the desired
results

Private Sub Worksheet_Change(ByVal Target As Range)
Dim OL As Object
Dim myAppt As Outlook.AppointmentItem
Dim myCell As Target

If Target.Column = 2 then

Set OL = CreateObject("outlook.application")

If Target.Value <> "Appointment added" Then
Set myAppt = OL.CreateItem(olAppointmentItem)
With myAppt
..Body = "An important reminder"
..Start = myCell.Value + 8 / 24
..Subject = "This is an important reminder"
..Save
End With
myCell(1,2).Value = "Appointment added"
End If

End if

End Sub