Is there code similar to "If Not Application.Intersect" & "If Not Intersect(Target..

[FrankM]

I already have code using If Not Intersect(Target...., so I can't use that again. I have 2 groups of code for the same cell range, using "If not Application.Intersect", when 1 runs the other runs also. I think I may have to use different code to have only 1 group of code run.

Here is the 1st group of code:

Option Explicit
' This works on the row, M when pending is entered, it also opens the users Outlook calendar.
' Pending #1. Example #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

Group 1 does run as expected, but then goes to group 2.
Here I the code for group 2:

' 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
End Sub

This group of code runs, but does not clear contents, & then goes to code group 1. Am I correct in thinking that I have to find different code for group 2?

[Bob Phillips]

That first code is not in a sub so cannot possibly run, the second has no sub definition, but 2 end subs, so will not run either.

What exactly are you trying to do?

[FrankM]

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.

[FrankM]

ok. I commented out pending #2, & am trying a different approach. BY commenting out Pending #2, Pending #1 works like a charm. I am thinking that Delete key activation code may solve my problem, for #2. I am looking for the groups thoughts. Also could it be limited to 1 column?

[FrankM]

I replaced pending #2 with the following code & placed it at the beginning of Worksheet_Change.

Private Sub Worksheet_Change(ByVal Target As Range)If Trim(Target.Value) = Empty 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")
olApp2.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

It runs & then throws a run time error '13' Type Mismatch on "If Trim(Target.Value) = Empty Then". Please educate me on what I am doing wrong & how to correct it. The other portions of the code work as expected.

[Paul_Hossler]

Try

If Len(Trim(Target.Value)) = 0 Then

[FrankM]

I tried your code. It ran, but did not let ....when pending is entered..... run. I have attached a sample, & hope I did it correctly. I narrowed down the problem. If "Pending" is deleted & :Yes" is selected, it runs & gives an error code. If "No" is chosen, it runs & no error code.

[Paul_Hossler]

You didn't say how to reproduce the issue, but just making a Delete on the Referals sheet I got the error

Some where in your code you're getting a Target with multiple cells and Trim doesn't work


Capture.JPG

[FrankM]

Paul. I appreciate your help. The problem is solved. Here is what I did. I added Application.EnableEvents = False & Application.EnableEvents = True.
Here is the code:

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

I placed Application.EnableEvents = False, before Range("$M$3:$M$329").ClearContents, & Application.EnableEvents = True, after. I think it was caught in a loop without the False statement. The cell started out filled, then deleted. If "Yes" was selected it went back to code line #1 If Trim(Target.Value) = Empty Then. By adding both the False & TRUE statements, I was able to prevent the loop & turn the Excel Events back on for future use.