Complex Yes/No Mesg Box Pop Up prior to deletion.

[FrancisM]

I am trying to code a pop up when the user deletes "Pending" Column M. I have searched for samples where; entry was deleted & the message had Yes/No response. I have a previous message saying "Two appointments were scheduled on your calendar previously. The first appointment was a reminder to send a contact letter. The second appointment was a reminder to cancel the consult. I would like to combine those lines & Click Yes to delete the previous entry, if veteran contacted you. Click No, if there was no contact from the veteran."
What I would like to happen is 1 of 2 actions. Action 1) the user selects Yes & a message pops up saying "Delete the future appointments on your calendar for this veteran." and then this piece of code runs:

     'Opens Outlook appointment Calendar.Dim olApp As Object ' Outlook.Application
Set olApp = CreateObject("Outlook.Application")
olApp.Session.GetDefaultFolder(olFolderCalendar).Display

Action 2) The user selects No & entry is deleted & the user is prompted to enter the reason in column L range L3:L329. "You can choose from the drop down list or enter a new one."
I already have an If Not Intersect(Target...." line so I can't use that, & this piece of code when Pending originally entered:

   Dim KeyCells As Range

Set KeyCells = Range("M3:M329")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then

I appreciate any help. I have not seen anything like I mentioned. I assume that it is possible, am I correct?

 

[FrancisM]

Ok. I have one problem, I have not been able to resolve. I have code that runs when change occurs in range M3:M329. When "Pending" is entered the 1st one runs, & the 2nd one runs. What code do you use to prevent VBA from going to pending #2 , after #1 has run. How can you have VBA go directly to pending #2 when the entry in Range M3:M329 has been deleted? I have included both the pending & surrounding code, so you ha an idea of the structure.

Private Sub Worksheet_Change(ByVal Target As Range)' This code strips the first 5 of the Social Security.
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
     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 [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=1]#1[/URL] .
    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
   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 entered, it also opens the users Outlook calendar.
 ' Pending [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=2]#2[/URL] .
    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 Reason Column. You can choose from the drop down list or enter a new one.", vbInformation, "Vocational Services Database - " & ActiveSheet.Name
      End Select
End If
End Sub

 

[FrancisM]

Problem solved.

Here is the code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)


 'This code is activated if the delete key is activated,
If Trim(Target.Value) = Empty Then
Dim Ans As Integer
Application.Speech.Speak "Two appointments were scheduled on your calendar previously. One for a Contact Letter, one to Cancel the Consult ", SpeakAsync:=True
       Application.Wait (Now + TimeValue("00:00:2"))
     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 + vbInformation, _
                       "Vocational Services Reminder")
      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")
olApp2.Session.GetDefaultFolder(olFolderCalendar).Display
Application.EnableEvents = False
Range("$M$3:$M$329").ClearContents
Application.EnableEvents = True
  End Select
  Select Case Ans
   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

This code runs anytime Delete is pressed on the worksheet.