VBA Validated userforms

[Sovereignty9]

Hi All you clever people.

I'm looking for a solution to my userform validation issues. I have 8 textboxes 6 of which need to be numerically validated, the other 2 do not. My problem is that I can get the numerical validation to work however it forces the 2 textboxes I don't want validated to be validated also. PLease see below the current coding.

Option Explicit
Private ExpensesTable As ListObject
Private CurrentRow As Long
Private WithEvents Calendar1 As cCalendar
'
'
'###############################################################
'# Calendar class written by                                   #
'# Krisztina Szabó                                             #
'# Gábor Madács                                                #
'# Roberto Mensa (nick r)                                      #
'# [URL]https://sites.google.com/site/e90e50/calendar-control-class[/URL] #
'###############################################################
'
Function IsAcceptedNumber(Ctrl As MSForms.Control) As Boolean
' Checks if :
'
' Ctrl.Value > 0
' Ctr.Value can be converted to valid double
' Ctr.Value returns TRUE from IsNumeric - bear in mind $4,4 is regarded as TRUE by IsNumeric
' Ctr.Value contains zero , (commas)
' Ctr.Value contains only one . (decimal point)
' Ctr.Value contains zero currency symbols
' Ctrl.Value has maximum two decimal places
'
    
    Dim DoubleValue As Double
    Dim CurrSym As String
    Dim DecSep As String
    Dim ThouSep As String
    
    'Check for system definitions of these
    CurrSym = Application.International(xlCurrencyCode)
    DecSep = Application.International(xlDecimalSeparator)
    ThouSep = Application.International(xlThousandsSeparator)
    
    'Ignore errors
    On Error Resume Next
        DoubleValue = CDbl(Ctrl.Value)
        'Value can't be converted to double or is negative
        If Err.Number <> 0 Or Not DoubleValue > 0 Then
        
            'Return error handling to Excel
            On Error GoTo 0
            IsAcceptedNumber = False
            FlagError Ctrl
            Exit Function
            
        Else
        
            'Return error handling to Excel
            On Error GoTo 0
        End If
        

    'If a decimal separator is present
    If (InStr(Ctrl.Value, DecSep) > 0) Then
    
        'Make sure the number contains a maximum of 2 decimal places
        If ((Len(Mid(Ctrl.Value, InStr(Ctrl.Value, DecSep))) - 1) > 2) Then
        IsAcceptedNumber = False
        FlagError Ctrl
        Exit Function
        
        End If
    End If
    
     
    ' If the value is greater than 0 AND
    ' is considered numeric AND
    ' contains 0 currency symbols AND
    ' contains 0 thousands separators AND
    ' contains no more than one decimal separator
    
    If Ctrl.Value > 0 And IsNumeric(Ctrl.Value) And (InStr(Ctrl.Value, CurrSym) = 0) And (InStr(Ctrl.Value, ThouSep) = 0) And (Len(Ctrl.Value) - Len(Replace(Ctrl.Value, DecSep, "")) <= 1) Then
    
        IsAcceptedNumber = True
        
    Else
        
        FlagError Ctrl
        IsAcceptedNumber = False
    
    End If
    
End Function
Sub FlagError(Ctrl As MSForms.Control)
    Ctrl.BorderStyle = fmBorderStyleSingle
    Ctrl.BorderColor = &HFF&
End Sub
Sub ClearError(Ctrl As MSForms.Control)
    Ctrl.BorderStyle = fmBorderStyleNone
    Ctrl.BorderColor = &H80000006
    Ctrl.SpecialEffect = fmSpecialEffectSunken
End Sub
Function CheckForErrors() As Integer
    Dim ErrorsFound As Integer
    Dim CompletedExpenses As Integer
    Const ExpensesFields As Integer = 5
    Dim aDecimal As Double
    Dim Ctrl As MSForms.Control
    ErrorsFound = 0
    CompletedExpenses = ExpensesFields
    For Each Ctrl In ExpensesForm.Controls
        
        Select Case TypeName(Ctrl)
        
            Case "TextBox"
                'If the text box is empty
                If Ctrl.Value = "" Then
                
                    'If the text box is not optional i.e. it must contain something
                    If Ctrl.Tag <> "Optional" Then
    
                        FlagError Ctrl
                        ErrorsFound = ErrorsFound + 1
                
                    Else
                
                        ClearError Ctrl
                        'At this point we have an empty expenses field.
                        'Record this for now and we'll check again later
                        CompletedExpenses = CompletedExpenses - 1
                    
                    End If
                
                           
                                 
                    
                     
                     If Ctrl.Name = "Airfare" Or IsAcceptedNumber(Ctrl) Then
                        ClearError Ctrl
                        
                    Else
                    
                        FlagError Ctrl
                        ErrorsFound = ErrorsFound + 1
                    End If
                    
                   
                    If Ctrl.Name = "Accommodation" Or IsAcceptedNumber(Ctrl) Then
                        ClearError Ctrl
                        
                    Else
                    
                        FlagError Ctrl
                        ErrorsFound = ErrorsFound + 1
                    End If
                    
                
                    If Ctrl.Name = "GroundTransport" Or IsAcceptedNumber(Ctrl) Then
                        ClearError Ctrl
                        
                    Else
                    
                        FlagError Ctrl
                        ErrorsFound = ErrorsFound + 1
                    End If
                    
                
                    If Ctrl.Name = "FoodDrink" Or IsAcceptedNumber(Ctrl) Then
                        ClearError Ctrl
                        
                    Else
                    
                        FlagError Ctrl
                        ErrorsFound = ErrorsFound + 1
                    End If
                    
                
                    If Ctrl.Name = "Misc" Or IsAcceptedNumber(Ctrl) Then
                        ClearError Ctrl
                        
                    Else
                    
                        FlagError Ctrl
                        ErrorsFound = ErrorsFound + 1
                    End If
                    
                
                    If Ctrl.Name = "Textbox2" Or IsAcceptedNumber(Ctrl) Then
                        ClearError Ctrl
                        
                    Else
                    
                        FlagError Ctrl
                        ErrorsFound = ErrorsFound + 1
                    End If
                End If
                
                
            
                
                
            Case "ComboBox"
                If Ctrl.ListIndex = -1 And (Ctrl.Name = "ClientName" Or Ctrl.Name = "StaffName") Then
                
                    FlagError Ctrl
                    ErrorsFound = ErrorsFound + 1
                
                Else
                
                    ClearError Ctrl
                
                End If
                
                
        End Select
        
    Next Ctrl
    
    
    'Chosen date can not be after today
    If Calendar1.Value > Date Then
    
        FlagError CalendarFrame
        ErrorsFound = ErrorsFound + 1
        
    Else
    
        ClearError CalendarFrame
    
    End If
    
    'If all expenses fields are empty
    If CompletedExpenses = 0 Then
    
        'Check each expenses field and flag the ones in error
        For Each Ctrl In ExpensesForm.Controls
        
            Select Case TypeName(Ctrl)
        
                Case "TextBox"
                    If Ctrl.Value = "" And Ctrl.Tag = "Optional" Then
    
                        FlagError Ctrl
                
                    End If
                                    
            End Select
        
        Next Ctrl
        
        CheckForErrors = 1
        
    Else
    
        CheckForErrors = ErrorsFound
        
    End If
    
End Function

Private Sub ResetForm()
    '
    '  Need to reset errors here too
    '
    
    Dim Ctrl As MSForms.Control
    For Each Ctrl In ExpensesForm.Controls
        
        Select Case TypeName(Ctrl)
        
            Case "TextBox"
                Ctrl.Text = ""
                ClearError Ctrl
                
                
            Case "ComboBox"
                If Ctrl.Name = "ClientName" Or Ctrl.Name = "StaffName" Then
                
                    Ctrl.ListIndex = -1
                    ClearError Ctrl
                    
                End If
                
        End Select
        
    Next Ctrl
    
    Calendar1.Value = Date
    ClearError CalendarFrame
End Sub
Private Sub PopulateForm(SelectedRow As Range)
        With SelectedRow
    
        Calendar1.Value = .Cells(1, 1).Value
        StaffName.Value = .Cells(1, 2).Value
        TextBox1.Value = .Cells(1, 3).Value
        Description.Value = .Cells(1, 4).Value
        Airfare.Value = .Cells(1, 5).Value
        Accommodation.Value = .Cells(1, 6).Value
        GroundTransport.Value = .Cells(1, 7).Value
        FoodDrink.Value = .Cells(1, 8).Value
         Misc.Value = .Cells(1, 9).Value
        TextBox2.Value = .Cells(1, 10).Value
      
            
    
    End With
End Sub
Private Sub UpdateRecordDisplay()
    With ExpensesTable
    
        RecordPosition.Caption = CurrentRow & " of " & .ListRows.Count
        PopulateForm .ListRows(CurrentRow).Range
        .ListRows(CurrentRow).Range.Select
        
    End With
            
End Sub
Private Sub Accommodation_Change()
End Sub
Private Sub AirfareLabel_Click()
End Sub
Private Sub ChangeRecord_SpinUp()
  
    If ExpensesTable.ListRows.Count < 1 Then Exit Sub
        
    If CurrentRow > 1 Then
      
        CurrentRow = CurrentRow - 1
            
        UpdateRecordDisplay
        
    End If
            
End Sub
Private Sub ChangeRecord_SpinDown()
    If CurrentRow = ExpensesTable.ListRows.Count Then Exit Sub
        
    If CurrentRow < ExpensesTable.ListRows.Count Then
      
        CurrentRow = CurrentRow + 1
            
        UpdateRecordDisplay
        
    End If
    
End Sub

Private Sub UpdatePositionCaption()
    RecordPosition.Caption = CurrentRow & " of " & ExpensesTable.ListRows.Count
    
End Sub
Private Sub ClearForm_Click()
    ResetForm
End Sub
Private Sub CommandButton1_Click()
Application.Goto Worksheets("Dashboard").Range("A1")
End Sub
Private Sub CommandButton2_Click()
Application.Goto Worksheets("Data").Range("A1")
End Sub
Private Sub CommandButton3_Click()
If MsgBox("Do you want save and send the PVS Nissan Packaging Tracking to everybody that needs it?", vbYesNo + vbQuestion, "Email") = vbYes Then
'send email
Module2.save
  
  'Variable declaration
    Dim oApp As Object, _
    oMail As Object, _
    WB As Workbook, _
    FileName As String, MailSub As String, MailTxt As String, Signature As String
    
     
     '*************************************************  ********
     'Set email details; Comment out if not required
    Const MailTo = "[EMAIL="PVS@nissan-nmuk.co.uk"]PVS@nissan-nmuk.co.uk[/EMAIL]"
    Const MailCC = "[EMAIL="joe.counter@plasticominum.com"]joe.counter@plasticominum.com[/EMAIL]"
    Const MailBCC = ""
    MailSub = "PVS Nissan Packaging Tracking " & Format(Now, "mm-dd-yy")
    MailTxt = "Hi All," & vbCrLf & vbNewLine & "Please find attached the updated Nissan PVS Nissan Packaging Tracking as of " & Format(Now, "mm-dd-yy") & "." & vbCrLf & vbNewLine & " " & vbNewLine
     '*************************************************  ********
     
     'Turns off screen updating
    Application.ScreenUpdating = False
     
    Set WB = ActiveWorkbook
     'Creates and shows the outlook mail item
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
    .Display
 End With
    With oMail
        .To = MailTo
        .Cc = MailCC
        .Bcc = MailBCC
        .Subject = MailSub
        .body = MailTxt & vbNewLine & Signature
        .Attachments.Add WB.FullName
        .Display
    End With
     
   
     
     'Restores screen updating and release Outlook
    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
    End If
End Sub
Private Sub CommandButton4_Click()
Module2.save
ActiveWorkbook.Close
End Sub
Private Sub DeleteExpenses_Click()
        'Set ExpensesTable = ActiveSheet.ListObjects("Expenses")
        
        If ExpensesTable.ListRows.Count < 1 Then Exit Sub
    
        With ActiveSheet.ListObjects("Expenses")
        
            .ListRows(CurrentRow).Delete
                        
            If ExpensesTable.ListRows.Count > 0 Then
            
                If CurrentRow > ExpensesTable.ListRows.Count Then
                
                    CurrentRow = ExpensesTable.ListRows.Count
                    
                End If
                
                .ListRows(CurrentRow).Range.Select
            
            Else
            
                CurrentRow = 0
            
            End If
                        
        End With
        
        ChangeRecord.Max = ChangeRecord.Max - 1
        
        UpdatePositionCaption
End Sub
 
Private Sub Description_Change()
End Sub
Private Sub InsertExpenses_Click()
    
    If CheckForErrors > 0 Then Exit Sub
    
    If CurrentRow = 0 Then CurrentRow = 1
    
    ActiveSheet.ListObjects("Expenses").ListRows.Add Position:=CurrentRow
    
    ModifyTableRow ExpensesTable.ListRows(CurrentRow).Range
    
    UpdatePositionCaption
    
End Sub
Private Sub Label3_Click()
End Sub
Private Sub Label6_Click()
End Sub
Private Sub Misc_Change()
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub UpdateExpenses_Click()
    
    If CheckForErrors > 0 Or ExpensesTable.ListRows.Count < 1 Then Exit Sub
    
    ModifyTableRow ExpensesTable.ListRows(CurrentRow).Range
    
End Sub
Private Sub UserForm_Initialize()
    Set ExpensesTable = ActiveSheet.ListObjects("Expenses")
    
    If Calendar1 Is Nothing Then
        
        Set Calendar1 = New cCalendar
        
        With Calendar1
            
            .Add_Calendar_into_Frame Me.CalendarFrame
            .UseDefaultBackColors = False
            .DayLength = 3
            .MonthLength = mlENShort
            .Height = 142
            .Width = 180
            .GridFont.Size = 7
            .DayFont.Size = 7
            .Refresh
        
        End With
    
    End If
    
    'Initialise for empty table
    ChangeRecord.Min = 0
    ChangeRecord.Max = 0
    CurrentRow = ExpensesTable.ListRows.Count
    
    If CurrentRow > 0 Then
    
        ChangeRecord.Min = 1
        ChangeRecord.Max = ExpensesTable.ListRows.Count
        
        'Load last record into form
        PopulateForm ExpensesTable.ListRows(ExpensesTable.ListRows.Count).Range
        ExpensesTable.ListRows(ExpensesTable.ListRows.Count).Range.Select
      
        UpdatePositionCaption
        
    Else
    
        RecordPosition.Caption = "0 of 0"
        
    End If
    
End Sub

Private Sub CloseForm_Click()
    Unload ExpensesForm
End Sub
Private Sub AddExpenses_Click()
    If CheckForErrors > 0 Then Exit Sub
    
    ActiveSheet.ListObjects("Expenses").ListRows.Add
    
    ModifyTableRow ExpensesTable.ListRows(ExpensesTable.ListRows.Count).Range
    
    UpdatePositionCaption
    
End Sub

Private Sub ModifyTableRow(TableRow As Range)
    
    With TableRow
    
        .Cells(1, 1) = Calendar1.Value
        .Cells(1, 2) = StaffName.Value
        .Cells(1, 3) = TextBox1.Value
        .Cells(1, 4) = Description.Value
        .Cells(1, 5) = Airfare.Value
        .Cells(1, 6) = Accommodation.Value
        .Cells(1, 7) = GroundTransport.Value
        .Cells(1, 8) = FoodDrink.Value
        .Cells(1, 9) = Misc.Value
        .Cells(1, 10) = TextBox2.Value
        .Cells(1, 11) = Time
               
            
        
    
    End With
    
    ChangeRecord.Max = ExpensesTable.ListRows.Count
    
End Sub

Many Thanks

Sovereignty9

 

[Warship]

I did not set up a test but at quick glance it seems to me that the 6 Controls to validate should have "And" not "Or".

Like:

If Ctrl.Name = "Airfare" And IsAcceptedNumber(Ctrl) Then

 

[Sovereignty9]

Many thanks for your response.

I tried your suggestion however nothing changed.

Sov