• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Previously working VBA code stopped working.

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:

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
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.
 

Attachments

  • sample.xlsm
    279.7 KB · Views: 0
Here is the working code:
Code:
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
    End Sub
The only thing I did was to move the code to the beginning of the Macro, & then kept adding & testing, until I found the lines that were causing the problem.
 
Back
Top