User entering non numeric value in cell range formatted for phone mumber.

[FrancisM]

I have cell range E4:E110, E13:E17 formatted for the phone number & if a non numeric is made, type mismatch message is given. The code titled 'This code formats the phone numbers in a certain format. is the batch I am trying add additional code to prevent non numeric entries. Here is the worksheet code:

Option Explicit

Public Sub AllowMacros()
'This allows a macro to run & keep the sheet protected.
Me.Protect UserInterfaceOnly:=True
End Sub

Private Sub Worksheet_Activate()
Call Do_Meeting
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'This code formats the phone numbers in a certain format.
    Dim vCopy As String
     Dim Num As Long
     Dim C As Range
     If Not Intersect(Target, Union(Range("E4:E10"), Range("E13:E17"))) Is Nothing Then
         For Each C In Target
             vCopy = C.Value
             For Num = VBA.Len(vCopy) To 1 Step -1
               If Not VBA.Mid(vCopy, Num, 1) Like "#" Then
                 Mid(vCopy, Num, 1) = Chr(32)
               End If
             Next
             vCopy = Replace(vCopy, " ", "")
             Application.EnableEvents = False
             Target.NumberFormat = "(000) 000-0000"
             Target.Value = CDec(vCopy)
             Application.EnableEvents = True
         Next C
     End If

    'This section of code clears the second listing of a duplicate, & allows the first.
    Dim r As Long
    If Not Intersect(Range("B5:B17,H4:H16"), Target) Is Nothing Then
        Application.EnableEvents = False
        For r = 5 To 17
            If Range("H" & r - 1).Value = "No" And Range("B" & r).Value <> "" Then
                Range("B" & r).ClearContents
            End If
        Next r
        Application.EnableEvents = True
    End If

    'This section of code provides notification if there is a scheduling conflict.
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("H5:H10, H13:H17")) Is Nothing Then
        If LCase(Target.Value) = LCase("No") Then
    
            MsgBox "If there is pink in a previously filled cell, after checking No." & vbCrLf & _
            "There is a Scheduling conflict." & vbCrLf & _
            "Choose another time or reschedule the first veteran" & vbCrLf & _
            "Remember! New Career Link Visits require 1 hour.", vbCritical, "Vocational Services - Career Link" & ActiveSheet.Name
        End If
        
 If Target.Address = "B4:B17" Then
Call Do_Carryover(Target)

  End If
        
    Call Do_Carryover(Target)
    
        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 If
    
    'This code activates a message box when No is entered in the column regarding New Visit.
    If Not Intersect(Target, Range("H4:H9,H13:H16")) Is Nothing Then
        If Target = "No" Then
          Application.Speech.Speak " New appointments require a 1 hour slot. Please fill in the Yellow colored cell. ", SpeakAsync:=True
            MsgBox "Veteran is qualified to meet with Career Link," & vbCrLf & "If they are:" & vbCrLf & "Ex-Offender  -  any jail time" & vbCrLf & "Homeless - if in the dom, or a shelter" & vbCrLf & "Low income - self-explanatory" & vbCrLf & "  " & vbCrLf & "These entires must be made upon Check In.", vbInformation, "Vocational Services - Career Link   " & ActiveSheet.Name
             Application.Speech.Speak " Please open the Referral Folder       to      check for         a  consult or          record          a  walk in  veteran. ", SpeakAsync:=True
        End If
    End If
   'This code prevents unauthorized word entry & instructs the user what is the appropriate action
    'in these ranges: B13:C17, E4:E10, E13:E17.
    If Target.Cells.Count = 1 Then
        If Not Intersect(Union(Range("B4:C10"), Range("B13:C17"), Range("E13:E17"), Range("E4:E10")), Target) Is Nothing Then
            Application.EnableEvents = False
            If LCase(Target.Value) = "canceled" Or LCase(Target.Value) = "canx" Or LCase(Target.Value) = "can" Or LCase(Target.Value) = "cancel" Or LCase(Target.Value) = "schedule" Or LCase(Target.Value) = "scheduled" Or LCase(Target.Value) = "Rescheduled" Or LCase(Target.Value) = "move" Or LCase(Target.Value) = "moved" Then
                Application.Undo
                'Informs user that they can not enter this text.
                  Application.Speech.Speak "This Action  is  not authorized. Click   the Move Canceled  button ", SpeakAsync:=True
                  MsgBox "Click the Move Canceled........... button", vbInformation, "Vocational Services - OVR   " & ActiveSheet.Name
                  Application.Wait (Now + TimeValue("00:00:01"))
                Application.EnableEvents = False
            End If
        End If
    End If
    
    Application.EnableEvents = True

        'This code prevents modification or deletion of cells in the range below.
        If Intersect(Target, Range("A2:T3,A21:C23,B11:T12,A18:B18,B32:M50,C18:F18,D21:F21,D23:F24,E20:F20,F22,D4:D17,D21,D23:F24,E20:F20:F24,D21:F21,F18,F20:F22,G18:F18,G18:J18,K18:M19,B63:M81,E87:P90,N4:N10,N13:N17,AI2:AJ3,AI4:AI10,AI13:AI17,AW1")) Is Nothing Then Exit Sub
        On Error GoTo ExitPoint
        Application.EnableEvents = False
        If Not IsDate(Target(1)) Then
        Application.Undo
        'Informs user that the cell that they clicked is locked.
         Application.Speech.Speak "You can't delete  or   modify cell contents  in this range. It is  locked.", SpeakAsync:=True
         Application.Wait (Now + TimeValue("00:00:01"))
         MsgBox " You can't delete or modify cell contents in this range " _
        , vbCritical, "Vocational Services - Career Link   " & ActiveSheet.Name
    End If
ExitPoint:
    Application.EnableEvents = True
    
    
    
 
  End Sub

Private Sub Worksheet_Deactivate()
 'Un-hides Ribbon. (Normal Ribbon Access)
    Application.ScreenUpdating = False
      Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
       Application.DisplayFormulaBar = True
        Application.DisplayStatusBar = True
         Application.ScreenUpdating = False
            ActiveWindow.View = xlNormalView
             Sheets("TOC").Select
End Sub

I have code that prevents non numeric entries, but I am having trouble adding the new code to the previous code. Here is the code to prevent non numeric entries:

Dim cell As Range
    Application.EnableEvents = False
    For Each cell In Target
        If Not Application.Intersect(cell, Range("E4:E17")) Is Nothing Then
           If Not IsNumeric(cell.Value) Then
              cell.Value = vbNullString
           End If
        End If
    Next cell
    Application.EnableEvents = True

 

[FrancisM]

I just learned that if a numeric value is deleted, the phone code also gives a type mismatch error.