I am trying to have 2 actions take place. Action 1. A user enters "Pending in Column range 3:329. a reminder window opens, the user clicks OK, & the Outlook Calendar opens. At a later date Pending is deleted, the user has 2 choices. Yes deletes pending, & Outlook calendar opens. No deletes pending, & the active cell is 1 cell to the left. I have included the entire batch of code, since my posting previously was not accurate enough. The areas I am having trouble with is pending 1 & 2.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' This code strips the first 5 of the Social Security.
'You can have only 1 "If Not Intersect" statement. If more, they do not run below this section.
Dim SSNcell As Range
'Test whether content should be an abbreviated SSN
'This restricts the area of application of the event handler
If Not Intersect(Target, Range("SSN")) Is Nothing Then
'Make sure the program does not trigger a further event
Application.EnableEvents = False
'Loop over intersection
For Each SSNcell In Intersect(Target, Range("SSN"))
SSNcell.Value = VBA.Right(SSNcell.Value, 4)
Next
'Reset
Application.EnableEvents = True
End If
' This works in the row that contains names.
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("C3:C329")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Application.Speech.Speak "Copy the Social Security Number directly from C P R S. The system stips the first five numbers. ", SpeakAsync:=True
Application.Wait (Now + TimeValue("00:00:2"))
MsgBox " Copy the Social Security Number directly from CPRS. The system strips the first five numbers. ", vbInformation, "Vocational Services Database - " & ActiveSheet.Name
Else
End If
' This works on the row, M when pending is entered, it also opens the users Outlook calendar.
' Pending #1.
Set KeyCells = Range("M3:M329")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Application.Speech.Speak "Schedule two. appointments on your calendar. The first appointment. is a reminder. to send a contact letter. (if no response from the Phone call). _
Use the Red date to the right. The second appointment. is a reminder. two weeks later. to cancel the consult. if NO response from earlier attempts.", SpeakAsync:=True
Application.Wait (Now + TimeValue("00:00:2"))
VBA.MsgBox "Schedule two appointments on your calendar. The first appointment is a reminder to send a contact letter (if no response from Phone call.) _
Use the Red date to the right. The second appointment is a reminder two weeks later to cancel the consult, if NO response from earlier attempts.", vbOKOnly + vbInformation, "Vocational Services Reminder"
'Opens Outlook appointment Calendar.
Dim olApp As Object ' Outlook.Application
Set olApp = CreateObject("Outlook.Application")
olApp.Session.GetDefaultFolder(olFolderCalendar).Display
End If
' The user is notified to take appropiate action, when VR is entered in column N.
Set KeyCells = Range("N3:N329")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Application.Speech.Speak "Click. Vocational Asstistance. Update Button. and verify that the name was entered. If it was entered. Click yes. for the appropriate service.", SpeakAsync:=True
VBA.MsgBox "Click Voc Asst Update Button, & verify that name was entered. If entered, Click yes for the appropriate service.", _
vbOKOnly + vbInformation, "Vocational Services Reminder"
End If
' This works on the row, M when pending is deleted, it also opens the users Outlook calendar.
' Pending #2.
Set KeyCells = Range("M3:M329")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Dim Ans As Integer
Ans = MsgBox("Two appointments were scheduled on your calendar previously. One for a Contact Letter, one to Cancel the Consult " & vbCrLf & vbNewLine _
& "Click Yes to delete the future appointments,if veteran contacted you. Click No, if there was no contact from the veteran.", vbYesNo, "Vocational Services Database - " & ActiveSheet.Name)
Select Case Ans
Case vbYes
'[code if Ans is Yes]...
'Opens Outlook appointment Calendar.
Dim olApp2 As Object ' Outlook.Application
Set olApp2 = CreateObject("Outlook.Application")
olApp.Session.GetDefaultFolder(olFolderCalendar).Display
Range("$M$3:$M$329").ClearContents
Case vbNo
' ...[code if Ans is No]...
MsgBox " Enter the reason in the Column. You can choose from the drop down list or enter a new one.", vbInformation, "Vocational Services Database - " & ActiveSheet.Name
ActiveCell.Offset(0, -1).Select
End Select
Exit Sub
End If
End Sub
Currently, when Pending 1 runs pending 2 also runs.
Here is the problems with pending 2; if the user clicks "Yes" it goes back to Pending #1; if no is clicked, Pending is not deleted, & the 1st cell left of M, becomes the active cell. If I comment out pending 2, Pending 1 works as expected.