Excel Worksheet_BeforeDelete code not working as expected.

Joined
Dec 13, 2017
Messages
71
Reaction score
19
I have a worksheet that that a user can enter "Pending" in column M. That is a temporary entry, eventually it is deleted.
The code below does work on the initial entry. But similar code does not work on Private Sub Worksheet_BeforeDelete().

Private Sub Worksheet_Change(ByVal Target As Range)
' Promts user wnen Pending is selected.
Application.Cursor = xlDefault
If Not Application.Intersect(Target(1), Me.Columns("M")) 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

End Sub

I am attempting to run code below prior to the deletion of the entry.
Here is the problem code:

Private Sub Worksheet_BeforeDelete()
' Promts user wnen Pending is selected.
Application.Cursor = xlDefault
If Not Application.Intersect(Target(1), Me.Columns("M")) Is Nothing Then
Application.Speech.Speak "Delete the 2 appointments on your calendar. The first appointment was the date to the right of Pending. The second was 2 weeks later", SpeakAsync:=True
MsgBox " Delete the 2 appointments on your calendar. The first appointment was the date to the right of Pending. The second was 2 weeks later. ", 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 Sub

When I debug, I get a "Sub or Function not defined" error on "Target". Yes the 2 codes are similar. I changed the messages only.
It is probably something very simple .
 
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


The code runs anytime delete is pressed on the worksheet.
 
Back
Top