Frncis
Member
I have code that strips the first 4 numbers from the social security; provides audio/visual reminders to copy names directly from records; prompts a user to schedule 2 appointments on their Outlook calendar & opens outlook; and prompts user to takes appropriate action when an entry is made. Here is the good code:
Below is the code that is causing the good code above not to work.
When the above code is added to the working code, it causes the entire code not to work (nothing happens). The funny thing is, initially it did work, & nothing was added or deleted. I have attached a small sample file, with the working code only. I have looked at the bad code & I can't see any thing wrong. I welcome any help.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
' 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 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 on the row, M when pending is entered, it also opens the users Outlook calendar.
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 appropriate 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
Application.Wait (Now + TimeValue("00:00:2"))
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"
Exit Sub
End If
End Sub
Below is the code that is causing the good code above not to work.
Code:
'This code is activated if the delete key is activated,
If Trim(Target.Value) = Empty Then
Dim Ans As Integer
'Pending delete.
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
MsgBox " If canceling, because the veteran replied. Choose an entry from the list, or enter a different one, in the Reason Column.", vbInformation, "Vocational Services Database - " & ActiveSheet.Name
Set olApp2 = CreateObject("Outlook.Application")
olApp2.Session.GetDefaultFolder(olFolderCalendar).Display
Application.EnableEvents = False
Range("$M$3:$M$329").ClearContents
Application.EnableEvents = True
ActiveCell.Offset(0, -1).Select
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