Userform UPDATE record and date issue

[Spaced69]

Hi guys need help with vba code for userform
Cells formated to date dd/mm/yyyy and use the isdate etc on userform....and if not a valid date wont accept....but noticed entering 07/12/18 will go into cell as 12/07/18...frustrating
Also managed to get update button to update data with addition of using vbyesno...but when running the vbyesno box remains and cant do anything unless i totally close

Not sure if can attach file

But any help is welcomed

 

[dmt32]

Hi,

Is it possible to have the pdate and sdate to have enter numbers on on the userform so that it inserts the /

Generally speaking when managing dates it easier to use a date picker but the built-in one is not available to all versions – There are some good home brew userform version published you can search for many of which are free.

You can though, manage date entry in a textbox to do roughly what you want & I have found some codes I have used in a past project which I have adjusted to hopefully, meet your need & added them to your project

Date Textboxes will now only allow numeric [0-9] & / character. You can now enter dates in any of the following formats

d/m/yy
dd/m/yy
dd/mm/yy
d/mm/yy
d/m/yyyy
dd/mm/yyyy
d/mm/yyyy
dd/m/yyyy
ddmmyyyy

If you enter a valid date the Textbox will have a white background & when you exit, it will then be formatted to the specified date format (dd/mm/yyyy). Invalid Dates Textbox is RED & if you exit you will get a warning.

So if you enter 17092019 or 17/9/19 & exit it should change to 17/09/2019

Is there a way to make all txt entries into ucase Especially the registration
Others would be nice as well

To do this you would use the Ucase Function which I have included in the updated code.

Replace all existing code with following

Dim EntryDate As Variant
Const RequiredDateFormat As String = "dd/mm/yyyy"


Private Sub cmdexit_Click()
Unload Me
End Sub


Private Sub cmdnew_Click()
    Dim Control As Variant
'clear controls
    For Each Control In ControlsArr
        Control.Text = ""
    Next
    
    Me.ComboBox1.Value = ""


     With Me.txtreg
        .Locked = False
        .SpecialEffect = fmSpecialEffectSunken
        .BackStyle = fmBackStyleOpaque
        .ForeColor = vbBlack
        .SetFocus
    End With
    
'change status
     With Me.cmdsubmit
        .Caption = "SUBMIT"
        .BackColor = vbBlack
    End With


End Sub


Private Sub cmdsubmit_Click()
    Dim erow As Long, c As Long
    Dim m As Variant, Control As Variant
    Dim RegNo As String
    Dim NewRecord As Boolean
    
    If Not AllComplete Then Exit Sub
    
    RegNo = Me.txtreg.Text
    
    m = Application.Match(RegNo, Sheet1.Columns(1), 0)
    NewRecord = CBool(IsError(m))
    
    If Not NewRecord Then If MsgBox(RegNo & Chr(10) & "Update Record?", 36, "Update Record") = vbNo Then Exit Sub
    
    With Sheet1
'get record row
        erow = IIf(NewRecord, .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row, CLng(m))
    End With
'add record to sheet
'note IsDate & IsNumeric functions do not always work as intended
    For Each Control In ControlsArr
        c = c + 1
        With Control
            If .Name Like "*date" And IsDate(.Text) Then
                With Sheet1.Cells(erow, c)
                    .Value = DateValue(.Text)
                    .NumberFormat = RequiredDateFormat
                End With
            ElseIf .Name Like "*price" And IsNumeric(.Text) Then
                With Sheet1.Cells(erow, c)
                    .Value = Val(.Text)
                    .NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
                End With
            Else
                Sheet1.Cells(erow, c).Value = UCase(.Text)
            End If
        End With
    Next
    
'inform user
    msg = IIf(NewRecord, "New Record Entered", "Record Updated")
    
    MsgBox RegNo & Chr(10) & msg, 64, msg
'refresh combobox
    If NewRecord Then ComboBox1_Refresh
End Sub


Private Sub ComboBox1_Refresh()
    Dim LastRow As Long
    With Me.ComboBox1
       .Clear
    LastRow = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
    .List = Sheet1.Cells(3, 1).Resize(LastRow - 2).Value2
    End With
End Sub


Private Sub ComboBox1_Change()
    Dim RegNo As String
    Dim m As Variant
    Dim c As Long
    
    RegNo = ComboBox1.Text
    If Len(RegNo) = 0 Then Exit Sub
    m = Application.Match(RegNo, Sheet1.Columns(1), 0)
    If Not IsError(m) Then
        For Each Control In ControlsArr
            c = c + 1
            Control.Text = UCase(Sheet1.Cells(CLng(m), c).Value)
        Next
'change status
        With Me.cmdsubmit
            .Caption = "UPDATE"
            .BackColor = vbRed
            .Enabled = True
        End With
'prevent editing
         With Me.txtreg
            .Locked = True
            .SpecialEffect = fmSpecialEffectFlat
            .BackStyle = fmBackStyleTransparent
            .ForeColor = vbWhite
         End With
    End If
End Sub
'***********************************************************************************************************************
'****************************************************PURCHASE DATE******************************************************


Private Sub txtmodel_AfterUpdate()
    Me.txtmodel.Text = UCase(Me.txtmodel.Text)
End Sub


Private Sub txtpdate_Change()
    With Me.txtpdate
     EntryDate = .Value
            If Len(EntryDate) > 2 Then
                .BackColor = IIf(IsValidDateFormat(EntryDate, RequiredDateFormat), &H80000005, &HFF&)
            Else
                .BackColor = &H80000005
            End If
    End With
End Sub


Private Sub txtpdate_AfterUpdate()
    With Me.txtpdate
       If .BackColor = &H80000005 Then .Value = EntryDate
    End With
End Sub


Private Sub txtpdate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Cancel = IsNotValidDateEntry(txtpdate)
End Sub


Private Sub txtpdate_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'allow numeric [0-9] / only
    KeyAscii = NumbersOnly(KeyAscii)
End Sub
'***********************************************************************************************************************


'****************************************************SALES DATE*********************************************************


Private Sub txtsdate_Change()
    With Me.txtsdate
     EntryDate = .Value
            If Len(EntryDate) > 2 Then
                .BackColor = IIf(IsValidDateFormat(EntryDate, RequiredDateFormat), &H80000005, &HFF&)
            Else
                .BackColor = &H80000005
            End If
    End With
End Sub


Private Sub txtsdate_AfterUpdate()
    With Me.txtsdate
       If .BackColor = &H80000005 Then .Value = EntryDate
    End With
End Sub


Private Sub txtsdate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Cancel = IsNotValidDateEntry(txtsdate)
End Sub


Private Sub txtsdate_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'allow numeric [0-9] / only
   KeyAscii = NumbersOnly(KeyAscii)
End Sub


'**********************************************************************************************************************


Private Sub txtreg_AfterUpdate()
    Dim a As Long
    Dim RegNo As String
    
    RegNo = Me.txtreg.Text
    
    If Len(RegNo) = 0 Then Exit Sub
    a = Application.WorksheetFunction.CountIf(Sheet1.Range("A:A"), RegNo)
    If a >= 1 Then
        MsgBox RegNo & Chr(10) & "Registration already exists", 16, "Record Exists"
        Me.txtreg = ""
    Else
        Me.txtreg.Text = UCase(Me.txtreg.Text)
    End If
End Sub


Private Sub UserForm_Initialize()
 ComboBox1_Refresh
 Me.txtpdate.MaxLength = 10
 Me.txtsdate.MaxLength = 10
End Sub


Function ControlsArr() As Variant
    ControlsArr = Array(txtreg, combo, txtmodel, txtpdate, txtpprice, txtsdate, txtsprice)
End Function


Function AllComplete() As Boolean
    Dim Control As Variant
    Dim i As Integer
'Function Validates all TextBoxes for correct data entry
    For Each Control In ControlsArr
        i = i + 1
        msg = Choose(i, "Registration", "Make", "Model", "Purchase Date", _
                        "Purchase Price", "Sales Date", "Sales Price")
        With Control
            If .Name Like "*date" Then
                AllComplete = CBool(IsDate(.Text))
            ElseIf .Name Like "*price" Then
                AllComplete = CBool(IsNumeric(.Text))
            Else
                AllComplete = CBool(Len(.Text) > 0)
            End If
        End With
        
        If Not AllComplete Then
            MsgBox "Please Enter " & msg, 48, "Entry Required"
            Control.SetFocus
            Exit Function
        End If
    Next
End Function


Function IsNotValidDateEntry(ByVal Control As Object) As Boolean
    Dim Cancel As Boolean
    With Control
        If Not .Parent.Visible Then Exit Function
        If Len(.Text) > 0 And Not IsValidDateFormat(.Text, RequiredDateFormat) Then
            MsgBox "Valid Date Required", 48, "Date Required"
            Cancel = True
            .BackColor = vbRed
        End If
    End With
    IsNotValidDateEntry = Cancel
End Function


Function IsValidDateFormat(ByRef DateEntry As Variant, ByVal RequiredFormat As String) As Boolean
    Dim DateFormat As Variant
    On Error Resume Next
'check valid date format
'allowable formats
'dd/mm/yy dd/m/yy d/m/yy d/mm/yy
'dd/mm/yyyy d/m/yyyy d/mm/yyyy dd/m/yyyy
'ddmmyyyy


    For Each DateFormat In Array("##/##/##", "##/#/##", "#/#/##", "#/##/##", _
                                "##/##/####", "#/#/####", "#/##/####", "##/#/####", _
                                "########")
        If DateEntry Like DateFormat Then
            If IsDate(CStr(DateValue(Format$(DateEntry, "##/##/####")))) Then
                DateEntry = CVar(DateValue(Format$(DateEntry, "##/##/####")))
                IsValidDateFormat = True
            End If
            
            If IsValidDateFormat Then DateEntry = Format(DateValue(DateEntry), RequiredFormat): Exit Function
        End If
    Next DateFormat
    On Error GoTo 0
End Function


Function NumbersOnly(ByVal KeyAscii As MSForms.ReturnInteger) As MSForms.ReturnInteger
    Select Case KeyAscii
'valid entries [0-9] "/"
    Case 47, 48 To 57
'valid
    Case Else
'cancel
        KeyAscii = 0
    End Select
    Set NumbersOnly = KeyAscii
End Function

ENSURE that you copy ALL the codes INCLUDING the two variables at the VERY TOP.

I also added function that does final check that all textboxes have data of correct data type.

Final comment, the list for your search combobox I would place on a separate sheet from the database sheet.

Dave