Hi all,
I'm having an issue whereby my userform pulls dates in a MM/DD/YYYY format. I have looked at different fixes to this on the web but am stuck with my codes.
I have pasted my userform code below to help locate where I can best put this fix. I'm no expert so please excuse any long winded code that could be shorter. The only issue I currently have is dates keep changing to MM/DD/YYYY strangley only when its possibly to do so. for e.g. if I type 15/05/2020 it stays as DD/MM/YYYY I assume because its impossible to make this MM/DD/YYYY. If there is anything else in this code that could be better please do let me know.
My Worksheet has the correct format but the userform then tries to switch to MM/DD/YYYY where it can so I assume I can rule out the worksheet and my PC is as per UK time and date reference as are my excel cells format.
Option Explicit
'Private variables
Dim cNum As Integer
Dim X As Integer
Public MyEntryBoxes As Collection
Private Sub cmdAdd_Click()
Dim nextrow As Range
'error handler
On Error GoTo ErrHandler:
'set the next row in the database
cmdAdd.BackColor = vbWhite
cmdAdd.ForeColor = vbBlack
Set nextrow = Sheet2.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
'check for values in the first 4 controls
For X = 1 To 4
If Me.Controls("Reg" & X).Text = "" Then
MsgBox "You must add all data"
Exit Sub
End If
Next
'check for duplicate payroll numbers
If WorksheetFunction.CountIf(Sheet2.Range("C:C"), Me.Reg1.value) > 0 Then
MsgBox "This staff member already exists"
Exit Sub
End If
'number of controls to loop through
cNum = 108
'add the data to the database
For X = 1 To cNum
nextrow = Me.Controls("Reg" & X).Text
Set nextrow = nextrow.Offset(0, 1)
Next
'clear the controls
For X = 1 To cNum
Me.Controls("Reg" & X).value = ""
Next
'sort the database
SortName
'error block
On Error GoTo 0
Exit Sub
ErrHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
Private Sub cmdAdd_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdAdd.BackColor = vbBlack
cmdAdd.ForeColor = vbWhite
End Sub
Private Sub cmdClose_Click()
Application.ScreenUpdating = False
Unload Me
Protect_All
Application.ScreenUpdating = True
End Sub
Private Sub cmdData_Click()
Sheet2.Select
End Sub
Sub Lookup()
'declare the variables
Dim rngFind As Range
Dim strFirstFind As String
'error statement
On Error GoTo ErrHandler:
'clear the listbox
lstLookup.Clear
'look up parts or all of full mname
With Sheet2.Range("mytable[Formal_Name]")
Set rngFind = .Find(txtLookup.Text, LookIn:=xlValues, lookat:=xlPart)
'if value found then set a variable for the address
If Not rngFind Is Nothing Then
strFirstFind = rngFind.Address
'add the values to the listbox
Do
If rngFind.Row > 1 Then
lstLookup.AddItem rngFind.Text
lstLookup.List(lstLookup.ListCount - 1, 1) = rngFind.Offset(0, -4)
lstLookup.List(lstLookup.ListCount - 1, 2) = rngFind.Offset(0, 3)
lstLookup.List(lstLookup.ListCount - 1, 3) = rngFind.Offset(0, 4)
lstLookup.List(lstLookup.ListCount - 1, 4) = rngFind.Offset(0, 5)
lstLookup.List(lstLookup.ListCount - 1, 5) = rngFind.Offset(0, 7)
lstLookup.List(lstLookup.ListCount - 1, 6) = rngFind.Offset(0, 8)
lstLookup.List(lstLookup.ListCount - 1, 7) = rngFind.Offset(0, 9)
lstLookup.List(lstLookup.ListCount - 1, 8) = rngFind.Offset(0, 104)
End If
'find the next address to add
Set rngFind = .FindNext(rngFind)
Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstFind
End If
End With
'disable payroll editing
Me.Reg1.Enabled = False
Me.cmdEdit.Enabled = False
'error block
On Error GoTo 0
Exit Sub
ErrHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
Private Sub cmdDelete_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdDelete.BackColor = vbBlack
cmdDelete.ForeColor = vbWhite
End Sub
Private Sub cmdEdit_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdEdit.BackColor = vbBlack
cmdEdit.ForeColor = vbWhite
End Sub
Private Sub cmdLookup_Click()
Lookup
cmdLookup.BackColor = vbWhite
cmdLookup.ForeColor = vbBlack
End Sub
Private Sub cmdLookup_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdLookup.BackColor = vbBlack
cmdLookup.ForeColor = vbWhite
End Sub
Private Sub cmdReset_Click()
'clear the Reg controls
cmdReset.BackColor = vbWhite
cmdReset.ForeColor = vbBlack
cNum = 108
For X = 1 To cNum
Me.Controls("Reg" & X).value = ""
Next
'enable adding new staff
Me.cmdAdd.Enabled = True
'enable adding new payroll number
Me.Reg1.Enabled = True
'clear the listbox
lstLookup.Clear
'clear the textbox
Me.txtLookup.value = ""
End Sub
Private Sub cmdReset_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdReset.BackColor = vbBlack
cmdReset.ForeColor = vbWhite
End Sub
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'declare the variables
Dim cPayroll As String
Dim i As Integer
Dim findvalue
'error block
'On Error GoTo ErrHandler:
'get the select value from the listbox
For i = 0 To lstLookup.ListCount - 1
If lstLookup.Selected(i) = True Then
cPayroll = lstLookup.List(i, 1)
End If
Next i
'find the payroll number
Set findvalue = Sheet2.Range("mytable[Payroll_Number]").Find(What:=cPayroll, LookIn:=xlValues).Offset(0, 0)
'add the database values to the userform
cNum = 108
For X = 1 To cNum
Me.Controls("Reg" & X).Text = findvalue
Set findvalue = findvalue.Offset(0, 1)
Next
'disable adding
Me.cmdAdd.Enabled = False
Me.cmdEdit.Enabled = True
'training due?
If IsDate(Reg80.Text) Then
If CDate(Reg80.Text) < Date Then
MsgBox "Training 2 Overdue - Please Check The Training Tab"
End If
End If
If IsDate(Reg76.Text) Then
If CDate(Reg76.Text) < Date Then
MsgBox "Training 1 Overdue - Please Check The Training Tab"
End If
End If
'error block
On Error GoTo 0
Exit Sub
'ErrHandler::
' MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
' & Err.Number & vbCrLf & Err.Description & vbCrLf & _
'"Please notify the administrator"
End Sub
Private Sub cmdDelete_Click()
'declare the variables
Dim findvalue As Range
Dim cDelete As VbMsgBoxResult
'check for values
cmdDelete.BackColor = vbWhite
cmdDelete.ForeColor = vbBlack
If Reg1.value = "" Or Reg5.value = "" Then
MsgBox "There is not data to delete"
Exit Sub
End If
'give the user a chance to change their mind
cDelete = MsgBox("Are you sure that you want to delete this staff member", vbYesNo + vbDefaultButton2, "Are you sure????")
If cDelete = vbYes Then
'delete the row
Set findvalue = Sheet2.Range("mytable[Payroll_Number]").Find(What:=Reg1, LookIn:=xlValues)
findvalue.EntireRow.Delete
End If
'clear the controls
For X = 1 To cNum
Me.Controls("Reg" & X).value = ""
Next
'refresh the listbox
Lookup
End Sub
Private Sub cmdEdit_Click()
'declare the variables
Dim findvalue As Range
'error handling
On Error GoTo ErrHandler:
cmdEdit.BackColor = vbWhite
cmdEdit.ForeColor = vbBlack
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
'check for values
If Reg4.value = "" Or Reg3.value = "" Then
MsgBox "There is not data to edit"
Exit Sub
End If
'edit the row
Set findvalue = Sheet2.Range("mytable[Payroll_Number]").Find(What:=Reg1, LookIn:=xlValues).Offset(0, 0)
'if the edit is a name then add it
Me.Reg5.value = Me.Reg4.value + " " + Me.Reg3.value
For X = 1 To cNum
findvalue = Me.Controls("Reg" & X).Text
Set findvalue = findvalue.Offset(0, 1)
Next
'refresh the listbox
Lookup
'error block
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
Exit Sub
ErrHandler:
MsgBox "An Error has Occurred " & vbCrLf & _
"The error number is: " & Err.Number & vbCrLf & _
Err.Description & vbCrLf & "Please notify the administrator"
End Sub
Private Sub Reg17_Change()
On Error GoTo errhnd
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers
If Not IsNumeric(Reg17.Text) And Reg17.Text <> "" Then
If Len(Reg17.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg17.Text = Abs(Round(Left(Reg17.Text, Len(Reg17.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg17.Text = ""
End If
ElseIf Reg17.Text <> "" Then
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg3_Change()
'get the full name
Me.Reg5.value = Me.Reg4.value + " " + Me.Reg3.value
End Sub
Private Sub Reg32_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg33_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg34_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg35_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg36_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg37_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg4_Change()
'get the full name
Me.Reg5.value = Me.Reg4.value + " " + Me.Reg3.value
End Sub
Private Sub Reg62_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With Me.Reg62
If Not IsDate(.value) Then
.SetFocus
MsgBox "Enter a valid date"
Exit Sub
End If
End With
End Sub
Private Sub Reg75_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg75.Text) And Reg75.Text <> "" Then
If Len(Reg75.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg75.Text = Abs(Round(Left(Reg75.Text, Len(Reg75.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg75.Text = ""
End If
ElseIf Reg75.Text <> "" Then
'Ensure Positive and No Decimals
Reg75.Text = Abs(Round(Reg75.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg79_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg79.Text) And Reg79.Text <> "" Then
If Len(Reg79.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg79.Text = Abs(Round(Left(Reg79.Text, Len(Reg79.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg79.Text = ""
End If
ElseIf Reg79.Text <> "" Then
'Ensure Positive and No Decimals
Reg79.Text = Abs(Round(Reg79.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg83_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg83.Text) And Reg83.Text <> "" Then
If Len(Reg83.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg83.Text = Abs(Round(Left(Reg83.Text, Len(Reg83.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg83.Text = ""
End If
ElseIf Reg83.Text <> "" Then
'Ensure Positive and No Decimals
Reg83.Text = Abs(Round(Reg83.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg87_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg87.Text) And Reg87.Text <> "" Then
If Len(Reg87.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg87.Text = Abs(Round(Left(Reg87.Text, Len(Reg87.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg87.Text = ""
End If
ElseIf Reg87.Text <> "" Then
'Ensure Positive and No Decimals
Reg87.Text = Abs(Round(Reg87.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg91_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg91.Text) And Reg91.Text <> "" Then
If Len(Reg91.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg91.Text = Abs(Round(Left(Reg91.Text, Len(Reg91.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg91.Text = ""
End If
ElseIf Reg91.Text <> "" Then
'Ensure Positive and No Decimals
Reg91.Text = Abs(Round(Reg91.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg95_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg95.Text) And Reg95.Text <> "" Then
If Len(Reg95.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg95.Text = Abs(Round(Left(Reg95.Text, Len(Reg95.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg95.Text = ""
End If
ElseIf Reg95.Text <> "" Then
'Ensure Positive and No Decimals
Reg95.Text = Abs(Round(Reg95.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg99_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg99.Text) And Reg99.Text <> "" Then
If Len(Reg99.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg99.Text = Abs(Round(Left(Reg99.Text, Len(Reg99.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg99.Text = ""
End If
ElseIf Reg99.Text <> "" Then
'Ensure Positive and No Decimals
Reg99.Text = Abs(Round(Reg99.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg103_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg103.Text) And Reg103.Text <> "" Then
If Len(Reg103.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg103.Text = Abs(Round(Left(Reg103.Text, Len(Reg103.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg103.Text = ""
End If
ElseIf Reg103.Text <> "" Then
'Ensure Positive and No Decimals
Reg103.Text = Abs(Round(Reg103.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg54_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg54.Text) And Reg54.Text <> "" Then
If Len(Reg54.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg54.Text = Abs(Round(Left(Reg54.Text, Len(Reg54.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg54.Text = ""
End If
ElseIf Reg54.Text <> "" Then
'Ensure Positive and No Decimals
Reg54.Text = Abs(Round(Reg54.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg55_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg55.Text) And Reg55.Text <> "" Then
If Len(Reg55.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg55.Text = Abs(Round(Left(Reg55.Text, Len(Reg55.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg55.Text = ""
End If
ElseIf Reg55.Text <> "" Then
'Ensure Positive and No Decimals
Reg55.Text = Abs(Round(Reg55.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg56_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg56.Text) And Reg56.Text <> "" Then
If Len(Reg56.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg56.Text = Abs(Round(Left(Reg56.Text, Len(Reg56.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg56.Text = ""
End If
ElseIf Reg56.Text <> "" Then
'Ensure Positive and No Decimals
Reg56.Text = Abs(Round(Reg56.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg59_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg59.Text) And Reg59.Text <> "" Then
If Len(Reg59.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg59.Text = Abs(Round(Left(Reg59.Text, Len(Reg59.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg59.Text = ""
End If
ElseIf Reg59.Text <> "" Then
'Ensure Positive and No Decimals
Reg59.Text = Abs(Round(Reg59.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg15_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Reg15.value = Format(Reg15.value, "£#,##0.00")
End Sub
Private Sub Reg15_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg15.Text) And Reg15.Text <> "" Then
If Len(Reg15.Text) > 1 Then
Reg15.Text = Abs(Round(Left(Reg15.Text, Len(Reg15.Text) - 1), 0))
Else
Reg15.Text = ""
End If
ElseIf Reg15.Text <> "" Then
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg24_Change()
'Show £
Reg24.value = Format(Reg24.value, "£###,##")
End Sub
Private Sub txtLookup_enter()
txtLookup.BackColor = vbYellow
txtLookup.ForeColor = vbBlack
End Sub
Private Sub txtLookup_Exit(ByVal Cancel As MSForms.ReturnBoolean)
txtLookup.BackColor = vbBlack
txtLookup.ForeColor = vbWhite
End Sub
Private Sub Userform_Initialize()
On Error GoTo 0
Me.Label149.Caption = "Welcome " & Application.UserName
Dim i As Long
Dim aControl As MSForms.Control
Dim NewEntryBox As clsEntryBox
Set MyEntryBoxes = New Collection
For i = 1 To 108
Set aControl = Nothing
On Error Resume Next
Set aControl = Me.Controls("Reg" & i)
On Error GoTo 0
Select Case TypeName(aControl)
Case "ComboBox"
Set NewEntryBox = New clsEntryBox
Set NewEntryBox.MyComboBox = aControl
MyEntryBoxes.Add Item:=NewEntryBox
Case "TextBox"
Set NewEntryBox = New clsEntryBox
Set NewEntryBox.MyTextBox = aControl
MyEntryBoxes.Add Item:=NewEntryBox
End Select
Next i
Set NewEntryBox = Nothing
End Sub
Private Sub Userform_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.ScreenUpdating = False
StopTimer
Sheet1.Select
Protect_All
Application.ScreenUpdating = True
End Sub
Private Sub StopTime_Click()
Application.Run "StopTimer"
Unload Me
End Sub
Private Sub Userform_Activate()
Application.Run "StartTimer"
End Sub
I'm having an issue whereby my userform pulls dates in a MM/DD/YYYY format. I have looked at different fixes to this on the web but am stuck with my codes.
I have pasted my userform code below to help locate where I can best put this fix. I'm no expert so please excuse any long winded code that could be shorter. The only issue I currently have is dates keep changing to MM/DD/YYYY strangley only when its possibly to do so. for e.g. if I type 15/05/2020 it stays as DD/MM/YYYY I assume because its impossible to make this MM/DD/YYYY. If there is anything else in this code that could be better please do let me know.
My Worksheet has the correct format but the userform then tries to switch to MM/DD/YYYY where it can so I assume I can rule out the worksheet and my PC is as per UK time and date reference as are my excel cells format.
Option Explicit
'Private variables
Dim cNum As Integer
Dim X As Integer
Public MyEntryBoxes As Collection
Private Sub cmdAdd_Click()
Dim nextrow As Range
'error handler
On Error GoTo ErrHandler:
'set the next row in the database
cmdAdd.BackColor = vbWhite
cmdAdd.ForeColor = vbBlack
Set nextrow = Sheet2.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
'check for values in the first 4 controls
For X = 1 To 4
If Me.Controls("Reg" & X).Text = "" Then
MsgBox "You must add all data"
Exit Sub
End If
Next
'check for duplicate payroll numbers
If WorksheetFunction.CountIf(Sheet2.Range("C:C"), Me.Reg1.value) > 0 Then
MsgBox "This staff member already exists"
Exit Sub
End If
'number of controls to loop through
cNum = 108
'add the data to the database
For X = 1 To cNum
nextrow = Me.Controls("Reg" & X).Text
Set nextrow = nextrow.Offset(0, 1)
Next
'clear the controls
For X = 1 To cNum
Me.Controls("Reg" & X).value = ""
Next
'sort the database
SortName
'error block
On Error GoTo 0
Exit Sub
ErrHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
Private Sub cmdAdd_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdAdd.BackColor = vbBlack
cmdAdd.ForeColor = vbWhite
End Sub
Private Sub cmdClose_Click()
Application.ScreenUpdating = False
Unload Me
Protect_All
Application.ScreenUpdating = True
End Sub
Private Sub cmdData_Click()
Sheet2.Select
End Sub
Sub Lookup()
'declare the variables
Dim rngFind As Range
Dim strFirstFind As String
'error statement
On Error GoTo ErrHandler:
'clear the listbox
lstLookup.Clear
'look up parts or all of full mname
With Sheet2.Range("mytable[Formal_Name]")
Set rngFind = .Find(txtLookup.Text, LookIn:=xlValues, lookat:=xlPart)
'if value found then set a variable for the address
If Not rngFind Is Nothing Then
strFirstFind = rngFind.Address
'add the values to the listbox
Do
If rngFind.Row > 1 Then
lstLookup.AddItem rngFind.Text
lstLookup.List(lstLookup.ListCount - 1, 1) = rngFind.Offset(0, -4)
lstLookup.List(lstLookup.ListCount - 1, 2) = rngFind.Offset(0, 3)
lstLookup.List(lstLookup.ListCount - 1, 3) = rngFind.Offset(0, 4)
lstLookup.List(lstLookup.ListCount - 1, 4) = rngFind.Offset(0, 5)
lstLookup.List(lstLookup.ListCount - 1, 5) = rngFind.Offset(0, 7)
lstLookup.List(lstLookup.ListCount - 1, 6) = rngFind.Offset(0, 8)
lstLookup.List(lstLookup.ListCount - 1, 7) = rngFind.Offset(0, 9)
lstLookup.List(lstLookup.ListCount - 1, 8) = rngFind.Offset(0, 104)
End If
'find the next address to add
Set rngFind = .FindNext(rngFind)
Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstFind
End If
End With
'disable payroll editing
Me.Reg1.Enabled = False
Me.cmdEdit.Enabled = False
'error block
On Error GoTo 0
Exit Sub
ErrHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
Private Sub cmdDelete_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdDelete.BackColor = vbBlack
cmdDelete.ForeColor = vbWhite
End Sub
Private Sub cmdEdit_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdEdit.BackColor = vbBlack
cmdEdit.ForeColor = vbWhite
End Sub
Private Sub cmdLookup_Click()
Lookup
cmdLookup.BackColor = vbWhite
cmdLookup.ForeColor = vbBlack
End Sub
Private Sub cmdLookup_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdLookup.BackColor = vbBlack
cmdLookup.ForeColor = vbWhite
End Sub
Private Sub cmdReset_Click()
'clear the Reg controls
cmdReset.BackColor = vbWhite
cmdReset.ForeColor = vbBlack
cNum = 108
For X = 1 To cNum
Me.Controls("Reg" & X).value = ""
Next
'enable adding new staff
Me.cmdAdd.Enabled = True
'enable adding new payroll number
Me.Reg1.Enabled = True
'clear the listbox
lstLookup.Clear
'clear the textbox
Me.txtLookup.value = ""
End Sub
Private Sub cmdReset_Exit(ByVal Cancel As MSForms.ReturnBoolean)
cmdReset.BackColor = vbBlack
cmdReset.ForeColor = vbWhite
End Sub
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'declare the variables
Dim cPayroll As String
Dim i As Integer
Dim findvalue
'error block
'On Error GoTo ErrHandler:
'get the select value from the listbox
For i = 0 To lstLookup.ListCount - 1
If lstLookup.Selected(i) = True Then
cPayroll = lstLookup.List(i, 1)
End If
Next i
'find the payroll number
Set findvalue = Sheet2.Range("mytable[Payroll_Number]").Find(What:=cPayroll, LookIn:=xlValues).Offset(0, 0)
'add the database values to the userform
cNum = 108
For X = 1 To cNum
Me.Controls("Reg" & X).Text = findvalue
Set findvalue = findvalue.Offset(0, 1)
Next
'disable adding
Me.cmdAdd.Enabled = False
Me.cmdEdit.Enabled = True
'training due?
If IsDate(Reg80.Text) Then
If CDate(Reg80.Text) < Date Then
MsgBox "Training 2 Overdue - Please Check The Training Tab"
End If
End If
If IsDate(Reg76.Text) Then
If CDate(Reg76.Text) < Date Then
MsgBox "Training 1 Overdue - Please Check The Training Tab"
End If
End If
'error block
On Error GoTo 0
Exit Sub
'ErrHandler::
' MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
' & Err.Number & vbCrLf & Err.Description & vbCrLf & _
'"Please notify the administrator"
End Sub
Private Sub cmdDelete_Click()
'declare the variables
Dim findvalue As Range
Dim cDelete As VbMsgBoxResult
'check for values
cmdDelete.BackColor = vbWhite
cmdDelete.ForeColor = vbBlack
If Reg1.value = "" Or Reg5.value = "" Then
MsgBox "There is not data to delete"
Exit Sub
End If
'give the user a chance to change their mind
cDelete = MsgBox("Are you sure that you want to delete this staff member", vbYesNo + vbDefaultButton2, "Are you sure????")
If cDelete = vbYes Then
'delete the row
Set findvalue = Sheet2.Range("mytable[Payroll_Number]").Find(What:=Reg1, LookIn:=xlValues)
findvalue.EntireRow.Delete
End If
'clear the controls
For X = 1 To cNum
Me.Controls("Reg" & X).value = ""
Next
'refresh the listbox
Lookup
End Sub
Private Sub cmdEdit_Click()
'declare the variables
Dim findvalue As Range
'error handling
On Error GoTo ErrHandler:
cmdEdit.BackColor = vbWhite
cmdEdit.ForeColor = vbBlack
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
'check for values
If Reg4.value = "" Or Reg3.value = "" Then
MsgBox "There is not data to edit"
Exit Sub
End If
'edit the row
Set findvalue = Sheet2.Range("mytable[Payroll_Number]").Find(What:=Reg1, LookIn:=xlValues).Offset(0, 0)
'if the edit is a name then add it
Me.Reg5.value = Me.Reg4.value + " " + Me.Reg3.value
For X = 1 To cNum
findvalue = Me.Controls("Reg" & X).Text
Set findvalue = findvalue.Offset(0, 1)
Next
'refresh the listbox
Lookup
'error block
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
Exit Sub
ErrHandler:
MsgBox "An Error has Occurred " & vbCrLf & _
"The error number is: " & Err.Number & vbCrLf & _
Err.Description & vbCrLf & "Please notify the administrator"
End Sub
Private Sub Reg17_Change()
On Error GoTo errhnd
'PURPOSE: Limit TextBox inputs to Postive Whole Numbers
If Not IsNumeric(Reg17.Text) And Reg17.Text <> "" Then
If Len(Reg17.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg17.Text = Abs(Round(Left(Reg17.Text, Len(Reg17.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg17.Text = ""
End If
ElseIf Reg17.Text <> "" Then
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg3_Change()
'get the full name
Me.Reg5.value = Me.Reg4.value + " " + Me.Reg3.value
End Sub
Private Sub Reg32_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg33_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg34_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg35_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg36_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg37_Change()
'Get Full Address
Me.Reg38.value = Me.Reg32.value + ", " + Me.Reg33.value + ", " + Me.Reg34.value + ", " + Me.Reg35.value + ", " + Me.Reg36.value + ", " + Me.Reg37.value
End Sub
Private Sub Reg4_Change()
'get the full name
Me.Reg5.value = Me.Reg4.value + " " + Me.Reg3.value
End Sub
Private Sub Reg62_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With Me.Reg62
If Not IsDate(.value) Then
.SetFocus
MsgBox "Enter a valid date"
Exit Sub
End If
End With
End Sub
Private Sub Reg75_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg75.Text) And Reg75.Text <> "" Then
If Len(Reg75.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg75.Text = Abs(Round(Left(Reg75.Text, Len(Reg75.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg75.Text = ""
End If
ElseIf Reg75.Text <> "" Then
'Ensure Positive and No Decimals
Reg75.Text = Abs(Round(Reg75.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg79_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg79.Text) And Reg79.Text <> "" Then
If Len(Reg79.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg79.Text = Abs(Round(Left(Reg79.Text, Len(Reg79.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg79.Text = ""
End If
ElseIf Reg79.Text <> "" Then
'Ensure Positive and No Decimals
Reg79.Text = Abs(Round(Reg79.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg83_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg83.Text) And Reg83.Text <> "" Then
If Len(Reg83.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg83.Text = Abs(Round(Left(Reg83.Text, Len(Reg83.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg83.Text = ""
End If
ElseIf Reg83.Text <> "" Then
'Ensure Positive and No Decimals
Reg83.Text = Abs(Round(Reg83.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg87_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg87.Text) And Reg87.Text <> "" Then
If Len(Reg87.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg87.Text = Abs(Round(Left(Reg87.Text, Len(Reg87.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg87.Text = ""
End If
ElseIf Reg87.Text <> "" Then
'Ensure Positive and No Decimals
Reg87.Text = Abs(Round(Reg87.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg91_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg91.Text) And Reg91.Text <> "" Then
If Len(Reg91.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg91.Text = Abs(Round(Left(Reg91.Text, Len(Reg91.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg91.Text = ""
End If
ElseIf Reg91.Text <> "" Then
'Ensure Positive and No Decimals
Reg91.Text = Abs(Round(Reg91.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg95_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg95.Text) And Reg95.Text <> "" Then
If Len(Reg95.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg95.Text = Abs(Round(Left(Reg95.Text, Len(Reg95.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg95.Text = ""
End If
ElseIf Reg95.Text <> "" Then
'Ensure Positive and No Decimals
Reg95.Text = Abs(Round(Reg95.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg99_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg99.Text) And Reg99.Text <> "" Then
If Len(Reg99.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg99.Text = Abs(Round(Left(Reg99.Text, Len(Reg99.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg99.Text = ""
End If
ElseIf Reg99.Text <> "" Then
'Ensure Positive and No Decimals
Reg99.Text = Abs(Round(Reg99.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg103_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg103.Text) And Reg103.Text <> "" Then
If Len(Reg103.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg103.Text = Abs(Round(Left(Reg103.Text, Len(Reg103.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg103.Text = ""
End If
ElseIf Reg103.Text <> "" Then
'Ensure Positive and No Decimals
Reg103.Text = Abs(Round(Reg103.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg54_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg54.Text) And Reg54.Text <> "" Then
If Len(Reg54.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg54.Text = Abs(Round(Left(Reg54.Text, Len(Reg54.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg54.Text = ""
End If
ElseIf Reg54.Text <> "" Then
'Ensure Positive and No Decimals
Reg54.Text = Abs(Round(Reg54.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg55_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg55.Text) And Reg55.Text <> "" Then
If Len(Reg55.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg55.Text = Abs(Round(Left(Reg55.Text, Len(Reg55.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg55.Text = ""
End If
ElseIf Reg55.Text <> "" Then
'Ensure Positive and No Decimals
Reg55.Text = Abs(Round(Reg55.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg56_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg56.Text) And Reg56.Text <> "" Then
If Len(Reg56.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg56.Text = Abs(Round(Left(Reg56.Text, Len(Reg56.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg56.Text = ""
End If
ElseIf Reg56.Text <> "" Then
'Ensure Positive and No Decimals
Reg56.Text = Abs(Round(Reg56.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg59_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg59.Text) And Reg59.Text <> "" Then
If Len(Reg59.Text) > 1 Then
'Remove Added Non-Numerical Character from Number
Reg59.Text = Abs(Round(Left(Reg59.Text, Len(Reg59.Text) - 1), 0))
Else
'Delete Single Non-Numerical Character
Reg59.Text = ""
End If
ElseIf Reg59.Text <> "" Then
'Ensure Positive and No Decimals
Reg59.Text = Abs(Round(Reg59.Text, 0))
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg15_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Reg15.value = Format(Reg15.value, "£#,##0.00")
End Sub
Private Sub Reg15_Change()
On Error GoTo errhnd
If Not IsNumeric(Reg15.Text) And Reg15.Text <> "" Then
If Len(Reg15.Text) > 1 Then
Reg15.Text = Abs(Round(Left(Reg15.Text, Len(Reg15.Text) - 1), 0))
Else
Reg15.Text = ""
End If
ElseIf Reg15.Text <> "" Then
End If
Exit Sub
errhnd:
End Sub
Private Sub Reg24_Change()
'Show £
Reg24.value = Format(Reg24.value, "£###,##")
End Sub
Private Sub txtLookup_enter()
txtLookup.BackColor = vbYellow
txtLookup.ForeColor = vbBlack
End Sub
Private Sub txtLookup_Exit(ByVal Cancel As MSForms.ReturnBoolean)
txtLookup.BackColor = vbBlack
txtLookup.ForeColor = vbWhite
End Sub
Private Sub Userform_Initialize()
On Error GoTo 0
Me.Label149.Caption = "Welcome " & Application.UserName
Dim i As Long
Dim aControl As MSForms.Control
Dim NewEntryBox As clsEntryBox
Set MyEntryBoxes = New Collection
For i = 1 To 108
Set aControl = Nothing
On Error Resume Next
Set aControl = Me.Controls("Reg" & i)
On Error GoTo 0
Select Case TypeName(aControl)
Case "ComboBox"
Set NewEntryBox = New clsEntryBox
Set NewEntryBox.MyComboBox = aControl
MyEntryBoxes.Add Item:=NewEntryBox
Case "TextBox"
Set NewEntryBox = New clsEntryBox
Set NewEntryBox.MyTextBox = aControl
MyEntryBoxes.Add Item:=NewEntryBox
End Select
Next i
Set NewEntryBox = Nothing
End Sub
Private Sub Userform_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.ScreenUpdating = False
StopTimer
Sheet1.Select
Protect_All
Application.ScreenUpdating = True
End Sub
Private Sub StopTime_Click()
Application.Run "StopTimer"
Unload Me
End Sub
Private Sub Userform_Activate()
Application.Run "StartTimer"
End Sub
