I'm looking for some help. I'm new to coding and have started creating this Vehicle database program in Excel for a friend to use.
He is wanting to be able to see all vehicles he owns, when registration is due as well as input any vehicle services that have been done.
- I have created a User form in Excel, one for adding a Vehicle and renewing Registration.
- This is working but I believe it isn't very efficient.
- Once I looked into it more and studied it more, I found that you shouldn't put information in the form as such; it is just a presenter and it should be read through modules and classes.
- I have tried doing this and I just get stuck and can't do it or get it to work. Is this required or is anything else in my coding to be fixed?
Please note that I didn't write the code for the calendar, hidebar or switch off. I can provide the code to them if required.
Vehicle Form Code
On the Vehicle form they fill out their Vehicle Details:
- text boxes (Date of purchase, Regonumber, Rego Expiry, Purchase Price, Kms at Purchase, the VIN, Make, Model)
- choices (Year of Vehicle, Colour of Vehicle, Type of Vehicle (Car, Light Rigid, Motorbike etc.), Fuel Type (Unleaded Diesel etc.), Premium Class (to do with our state registration), Transmission Type (Automatic, Manual), Usage Type (whether they use the vehicle for Private or Business)
If they input Purchase price at a date after today it pops up an invalid date warning and makes the textbox red; if the Expiry Date is more than 4 months ago the same thing happens.
- The Purchase Date, (Rego, Expiry - if the Unregistered button isn't ticked), Year, Make, Model, Vehicle Type, Transmission type and Usage is required to be filled out to submit the vehicle to the table.
- When they click Add it adds it to the Table and unloads. If they click Cancel, a message box pops up to confirm, if yes then it just unloads.
Option Explicit
Private Sub UserForm_Initialize()
Dim i As Long, a As Long
Dim ws As Worksheet: Set ws = dropdown
'hides the address bar at the top
HideBar Me
'things to make excel run quicker
SwitchOff (True)
With Me
'Set Form Size
.Height = 300
.Width = 364
'Hide Invalid date warning
.Invalid_date.Visible = False
.Invalid_Expiry.Visible = False
'set Price Format
.VCH_Price = "$"
'count every year from this year to 1940 and add to Vechile year list.
For i = VBA.Year(Now()) To a Step -1
.VCH_year.AddItem i
If i = 1940 Then Exit For
Next
'create comboboxes from tables on dropdown list page
.VCH_Fuel.List = ws.Range("Fuel").Value2
.VCH_Trans.List = ws.Range("Trans").Value2
.VCH_Body.List = ws.Range("Colour").Value2
.VCH_Type.List = ws.Range("type").Value2
.VCH_Usage.List = ws.Range("Usage").Value2
.VCH_Premium.List = ws.Range("Premium").Value2
End With
End Sub
Private Sub OKButton_Click()
Dim Vehicle_ID As String, result As Boolean
Set TblVehicle = VehicleSheet.ListObjects("Tbl_Vehicle")
'things to make excel conditions go back to what they were
SwitchOff (False)
'Loops through all the boxes and check the required are filled in
result = FrmVehicleCheck(Me)
If result = False Then MsgBox "missing information", vbInformation: Exit Sub
'this creates the Vehicle id by adding make, model, body, year and rego together
Vehicle_ID = VCH_Make & " " & VCH_Model & " " & VCH_Body & " " & VCH_year & " " & VCH_Rego
'this loads the form onto the Vehicle table
With TblVehicle.ListRows.Add
.Range(1) = Vehicle_ID
.Range(2) = VCH_Rego.value
.Range(3) = IIf(VCH_Expiry = vbNullString, vbNullString, CDate(VCH_Expiry.value))
'New rego date column goes here
If Unregistered.value = True Then .Range(4) = "Yes"
.Range(5) = VCH_year.value
.Range(6) = VCH_Make.value
.Range(7) = VCH_Model.value
.Range(8) = VCH_Body.value
.Range(9) = VCH_Vin.value
.Range(10) = VCH_Trans.value
.Range(11) = VCH_Fuel.value
.Range(12) = VCH_Usage.value
.Range(13) = VCH_Type.value
.Range(14) = VCH_Premium.value
.Range(15) = VCH_Kms.value
.Range(16) = CDate(VCH_date.value)
.Range(17) = VCH_Price.value
End With
Unload Me
End Sub
Private Sub CancelButton_click()
'checks to make sure you want to cance
Dim result As String
result = MsgBox("Are you sure you want to cancel", vbYesNo)
If result = vbNo Then Exit Sub
SwitchOff (False)
Unload Me
End Sub
Private Sub VCH_date_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'when user double clicks on the date it will launch the calendar form then return with the value (picked)
Launch
With VCH_date
.value = (picked)
.value = VCH_date.value
End With
VCH_Rego.SetFocus
End Sub
Private Sub VCH_expiry_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'when user double clicks on the date it will launch the calendar form then return with the value (picked)
Launch
With VCH_Expiry
.value = (picked)
.value = VCH_Expiry.value
End With
VCH_Price.SetFocus
End Sub
Private Sub VCH_make_keypress( _
ByVal KeyAscii As MSForms.ReturnInteger)
With VCH_Make
If .value = vbNullString Then .BackColor = &H80000005
End With
End Sub
Private Sub VCH_type_DropButtonClick()
With VCH_Type
If .value = vbNullString Then .BackColor = &H80000005
End With
End Sub
Private Sub VCH_usage_DropButtonClick()
With VCH_Usage
If .value = vbNullString Then .BackColor = &H80000005
End With
End Sub
Private Sub VCH_trans_DropButtonClick()
With VCH_Trans
If .value = vbNullString Then .BackColor = &H80000005
End With
End Sub
Private Sub VCH_model_keypress( _
ByVal KeyAscii As MSForms.ReturnInteger)
With VCH_Model
If .value = vbNullString Then .BackColor = &H80000005
End With
End Sub
Private Sub VCH_year_DropButtonClick()
With VCH_year
If .value = vbNullString Then .BackColor = &H80000005
End With
End Sub
Private Sub VCH_Rego_keypress( _
ByVal KeyAscii As MSForms.ReturnInteger)
With VCH_Rego
If .value = vbNullString Then .BackColor = &H80000005
End With
End Sub
Private Sub VCH_date_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'if purchase date is later than today show error
With VCH_date
If IsDate(.value) Then
If CDate(.value) > Date Then
Invalid_date.Visible = True
.BackColor = &HC0C0FF
Else: Invalid_date.Visible = False
.BackColor = &H80000005
End If
End If
End With
End Sub
Private Sub VCH_expiry_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'if expiry date is before than today show error
With VCH_Expiry
If IsDate(.value) Then
If CDate(.value) < DateAdd("m", -4, Date) Then
Invalid_Expiry.Visible = True
.BackColor = &HC0C0FF
Else: Invalid_Expiry.Visible = False
.BackColor = &H80000005
End If
End If
End With
End Sub
Private Sub VCH_price_change()
VCH_Price = Format(VCH_Price, "$###,##")
End Sub
Private Sub VCH_price_KeyPress( _
ByVal KeyAscii As MSForms.ReturnInteger)
'makes it so user can only input numbers in text box and changes them to a $ figure
Select Case KeyAscii
Case Is < vbKey0, Is > vbKey9
KeyAscii = 0
Beep
End Select
End Sub
Private Sub VCH_kms_KeyPress( _
ByVal KeyAscii As MSForms.ReturnInteger)
'makes it so user can only input numbers in text box
Select Case KeyAscii
Case Is < vbKey0, Is > vbKey9
KeyAscii = 0
Beep
End Select
End Sub
Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
'PURPOSE: Reset Userform buttons to Inactive Status
CancelButtonInactive.Visible = True
OKButtonInactive.Visible = True
End Sub
Sub OKButtonInactive_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
'PURPOSE: Make OK Button appear Green when hovered on
CancelButtonInactive.Visible = True
OKButtonInactive.Visible = False
End Sub
Sub CancelButtonInactive_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
'PURPOSE: Make Cancel Button appear Green when hovered on
CancelButtonInactive.Visible = False
OKButtonInactive.Visible = True
End Sub
Vehicle Module Code
Option Explicit
Sub Add_Vehicle_Click()
If ActiveSheet.Name <> "Vehicle" Then
Sheets("Vehicle").Activate
Application.Wait (Now + 0.000006)
Else: Sheets("Vehicle").Activate
End If
Add_Vehicle.Show
End Sub
'checked to make sure all the correct boxes in Add Vehicle are filled in
Public Function FrmVehicleCheck(FrmVehicle As UserForm) As String
Dim result As String
Dim ctrl As Control
Set ctrl = Nothing
With FrmVehicle
For Each ctrl In .Controls
If ctrl.Tag = "*" Then
If Len(ctrl.Text) = 0 Then
If Not ((ctrl.Name = "VCH_Rego" Or _
ctrl.Name = "VCH_Expiry") And _
.Unregistered.value = True) Then
Debug.Print ctrl.Name
ctrl.BackColor = &HC0C0FF
result = ctrl.Name
End If
End If
End If
Next ctrl
End With
FrmVehicleCheck = IIf(Len(result) = 0, True, False)
'clearing references
Set ctrl = Nothing
Set FrmVehicle = Nothing
End Function
Registration Renewal
With the Registration Renewal form:
- The ComboBox has the Vehicle registrations from the Vehicle table where the vehicle hasn't been marked as disposed or unregistered and the Vehicle Expiry date is within 4 months of today.
- If they Select either Private or Business it clears all selections and populates the Registration Combobox with the above conditions but also filters and only populates the vehicles relevant to the selection (Private or Business).
- Once a vehicle has been selected then there are 4 Label boxes under the Registration Combobox that populate the information from selected. (I will provide a photo of this). It also populates the Registration Expiry date and makes the renewal period options appear (3 Months, 6 Months, 12 Months).
- Once one of the renewal periods are selected it populates the New Expiry date Label.
- You input the total. If you want to complete more renewals you select the More Renewals tick box.
- You then press Add; it inputs all the data in the Renewals Table and updates the Expiry date in the Vehicles table.
- If the More Renewals box was ticked it returns the form in a cleared state to update another Registration Expiry otherwise it unloads.
- If you press cancel a warning pops up and if you press okay it unloads.
Option Explicit
Private rownum As String, Optmonth As String
Private Sub UserForm_Initialize()
Set FrmRenewal = Me
Set TblVehicle = [Tbl_Vehicle].ListObject
Dim Vehicle As New ClsVehicle
'hide address bar
HideBar Me
'make excel run faster
SwitchOff (True)
'Run procedure to get Rego data that is has expired less than 4 months ago and due within the next 3 months
Rego_Filtered_Data
'hide the period selection buttons until a rego is selected
UpdatePeriods ("Hide")
'set form size and hide the Period buttons
With Me
'.Rego_ID.AddItem Vehicle.Regodue
.Height = 235
.Width = 274
End With
End Sub
Private Sub Rego_Bus_Click()
'clear data from form
'filter the Rego ID to only show Business Vehicles
clearform ("Bus")
filterusage ("Business")
End Sub
Private Sub Rego_pri_Click()
'clear data from form
'filter the Rego ID to only show Private Vehicles
clearform ("Pri")
filterusage ("Private")
End Sub
Private Sub Rego_ID_Click()
'auto populates Vechicle details and populates vehicle details and expiry dates
'clear all previous data
UpdatePeriods
With Me
'Attempt to find value in Table's first Column
rownum = RegoRownum(Rego_ID.value)
'get data from each column and input into the form
.Rego_Num.Caption = TblVehicle.DataBodyRange(rownum, 2)
.Rego_Make.Caption = TblVehicle.DataBodyRange(rownum, 6)
.Rego_Model.Caption = TblVehicle.DataBodyRange(rownum, 7)
.Rego_Colour.Caption = TblVehicle.DataBodyRange(rownum, 8)
.Rego_Expiry.value = Format(TblVehicle.DataBodyRange(rownum, 3), "DD/MM/YYYY")
'if the Rego expiry box isnt empty then calculate the Rego renewal periods and input them
If Not .Rego_Expiry.value = vbNullString Then UpdatePeriods (Rego_Expiry.value)
End With
End Sub
Private Sub OKButton_Click()
Set TblRenewal = [Tbl_Renewal].ListObject
' if relevent sections arent filled out make them red and return back to form
If FrmRenewalcheck = False Then MsgBox "missing information", vbInformation: Exit Sub
'input data into the Renewal table
With TblRenewal.ListRows.Add
.Range(1) = Rego_ID.Text
.Range(2) = Rego_Num.BoundValue
.Range(3) = Rego_Make.BoundValue
.Range(4) = Rego_Model.BoundValue
.Range(5) = CDate(Rego_Expiry.BoundValue)
.Range(6) = CDate(New_Date.BoundValue)
.Range(7) = Optmonth
.Range(8) = Total.value
.Range(9) = Date
End With
'look in the Vehicle table for the Rego ID and input the new expiry date in the New Rego Date field
rownum = RegoRownum(Rego_ID.value)
TblVehicle.DataBodyRange(rownum, 3) = CDate(New_Date.BoundValue)
'if the more renewals button is pressed restart form, if not clcose form
If More = True Then
SwitchOff (False)
clearform ("Refresh")
Rego_Filtered_Data
SwitchOff (True)
Exit Sub
Else: Unload Me
End If
SwitchOff (False)
'removing references
Set TblVehicle = Nothing
End Sub
Private Sub CancelButton_click()
'checking you want to cancel
Dim result As String
result = MsgBox("Are you sure you want to cancel", vbYesNo)
If result = vbNo Then Exit Sub
SwitchOff (False)
Unload Me
Set TblVehicle = Nothing
End Sub
Private Sub Option3M_Click()
'clears the other two Renewal button values and inputs the period renewal date in the new expiry period
Optmonth = Newperiod("Option3M")
End Sub
Private Sub Option6M_Click()
'clears the other two Renewal button values and inputs the period renewal date in the new expiry period
Optmonth = Newperiod("Option6M")
End Sub
Private Sub Option12M_Click()
'clears the other two Renewal button values and inputs the period renewal date in the new expiry period
Optmonth = Newperiod("Option12M")
End Sub
Private Sub Total_change()
Total = Format(Total, "$###,##")
End Sub
Private Sub Total_KeyPress( _
ByVal KeyAscii As MSForms.ReturnInteger)
'makes it so user can only input numbers in text box and changes them to a $ figure
Select Case KeyAscii
Case Is < vbKey0, Is > vbKey9
KeyAscii = 0
Beep
End Select
End Sub
Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
'PURPOSE: Reset Userform buttons to Inactive Status
CancelButtonInactive.Visible = True
OKButtonInactive.Visible = True
End Sub
Sub OKButtonInactive_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
'PURPOSE: Make OK Button appear Green when hovered on
CancelButtonInactive.Visible = True
OKButtonInactive.Visible = False
End Sub
Sub CancelButtonInactive_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
'PURPOSE: Make Cancel Button appear Green when hovered on
CancelButtonInactive.Visible = False
OKButtonInactive.Visible = True
End Sub
Renewal module
Option Explicit
Sub Rego_Renewal_Click()
Rego_Renewal.Show
End Sub
Global TblVehicle As ListObject, TblRenewal As ListObject, FrmRenewal As MSForms.UserForm
Dim ctrl As Control, rowNumbers() As Long ' Array to store row numbers
Sub Rego_Filtered_Data()
Dim RngRego As Range: Set RngRego = TblVehicle.ListColumns("Vehicle ID").DataBodyRange
Dim RngExpiry As Range: Set RngExpiry = TblVehicle.ListColumns("Rego expiry").DataBodyRange
Dim RngDisposed As Range: Set RngDisposed = TblVehicle.ListColumns("Disposal Date").DataBodyRange
Dim x As Long, rw As Long
Dim StrRego_filtered As String
Dim beforedate As Date, afterdate As Date
beforedate = DateAdd("m", 4, Date)
afterdate = DateAdd("m", -4, Date)
x = 1
'look for registrations that expired 4 months ago to due in the next 4 months and return in a combobox
'if vehicle is marked as disposed then skip and dont show in renewal
If Not IsEmpty(RngDisposed.Cells(rw, 1)) Then
For rw = RngRego.Rows.Count To 1 Step -1
Select Case RngExpiry.Cells(rw, 1)
Case afterdate To beforedate
StrRego_filtered = RngRego.Cells(rw, 1).value
Debug.Print StrRego_filtered
Debug.Print RngExpiry.Cells(rw, 1).value
With FrmRenewal.Rego_ID
.AddItem StrRego_filtered
.ColumnCount = 1
End With
ReDim Preserve rowNumbers(1 To x)
rowNumbers(x) = rw
x = x + 1
End Select
Debug.Print rw
Next rw
End If
Debug.Print StrRego_filtered
Application.ScreenUpdating = False
End Sub
Function FrmRenewalcheck() As String
Dim result As String
Dim Counta As Byte
Set ctrl = Nothing
Counta = 0
For Each ctrl In FrmRenewal.Controls
With ctrl
Select Case TypeName(ctrl)
Case "ComboBox"
If .ListIndex = -1 Then
.BackColor = &HC0C0FF
Debug.Print .Name
result = .Name
End If
Case "Label"
If .Name = "New_Date" And .Caption = vbNullString Then
.BackColor = &HC0C0FF
Debug.Print .Name
result = .Name
End If
Case "OptionButton"
If .GroupName = "Period" And .value = False Then
If Left(.Name, 6) = "Option" Then Counta = Counta + 1
If Counta = 3 Then
With FrmRenewal
.Option3M.BackColor = &HC0C0FF
.Option6M.BackColor = &HC0C0FF
.Option12M.BackColor = &HC0C0FF
result = ctrl.Name
Debug.Print ctrl.Name
End With
End If
End If
Case "TextBox"
If Len(.Text) = 0 Then
.BackColor = &HC0C0FF
Debug.Print .Name
result = .Name
End If
End Select
End With
Next ctrl
FrmRenewalcheck = IIf(Len(result) = 0, True, False)
'clearing references
Set ctrl = Nothing
End Function
Function Newperiod(OpName As String) As String
Dim SelPeriod As String
'initialise
Set ctrl = Nothing
'loop controls looking for option button that is
'both true and part of input GroupName
For Each ctrl In FrmRenewal.Controls
Select Case TypeName(ctrl)
Case Is = "OptionButton"
If ctrl.GroupName = "Period" Then
If ctrl.Name = OpName Then
ctrl.value = True
SelPeriod = Replace(OpName, "Option", "Rego_")
FrmRenewal.New_Date = FrmRenewal.Controls.Item(SelPeriod)
Newperiod = SelPeriod
FrmRenewal.Total = vbNullString
Else: ctrl.value = False
End If
End If
End Select
Next ctrl
'clear references
Set ctrl = Nothing
End Function
Public Sub clearform(proc As String)
Set ctrl = Nothing
For Each ctrl In FrmRenewal.Controls
With ctrl
Select Case .Tag
Case Is = "clear"
Select Case TypeName(ctrl)
Case Is = "TextBox"
.value = vbNullString
.BackColor = &H80000005
Case Is = "ComboBox"
.Clear
.BackColor = &H80000005
Case Is = "Label"
.Caption = vbNullString
.BackColor = &H80000005
Case Is = "OptionButton"
.Visible = False
.value = False
.BackColor = &H80000005
Case Is = "CheckBox"
.value = False
.BackColor = &H80000005
End Select
Case Is = vbNullString
If TypeName(ctrl) = "OptionButton" And proc = "Refresh" Then .value = False: .BackColor = &H80000005
End Select
End With
Next ctrl
Set ctrl = Nothing
End Sub
Function filterusage(Opttype As String)
Dim filteredRows() As Range ' Array to store filtered rows
Dim finalRowCount As Long
Dim StrRego_filteredUsage As String
Dim i As Long ' Variable to iterate through the row numbers array
' Loop through the row numbers array
For i = LBound(rowNumbers) To UBound(rowNumbers)
' Access the corresponding row in the table using the row number
Dim currentRow As Range
Set currentRow = TblVehicle.DataBodyRange.Rows(rowNumbers(i))
' Check if another column meets the additional criteria
Dim rngUsage As Range
Set rngUsage = currentRow.Cells(, 12) ' Replace columnNumber with the desired column index
' Apply additional filtering based on the criteria
If rngUsage.value = Opttype Then
' Add the filtered row to the array
Dim RngRego As Range
Set RngRego = TblVehicle.ListColumns(1).DataBodyRange
StrRego_filteredUsage = RngRego.Cells(rowNumbers(i), 1).value
Debug.Print StrRego_filteredUsage
With FrmRenewal.Rego_ID
.AddItem StrRego_filteredUsage
.ColumnCount = 1
End With
ReDim Preserve filteredRows(1 To finalRowCount + 1)
End If
Next i
End Function
Function RegoRownum(VehicleID As String) As Long
Dim FoundCell As Range
On Error Resume Next
Set FoundCell = TblVehicle.DataBodyRange.Columns(1).Find(VehicleID, LookAt:=xlWhole)
On Error GoTo 0
If Not FoundCell Is Nothing Then RegoRownum = _
TblVehicle.ListRows(FoundCell.Row - TblVehicle.HeaderRowRange.Row).index
End Function
Function UpdatePeriods(Optional NewVal As String) As Long
With FrmRenewal
Select Case NewVal
Case Is = vbNullString
.Option3M.value = False
.Option6M.value = False
.Option12M.value = False
.Rego_3M = vbNullString
.Rego_6M = vbNullString
.Rego_12M = vbNullString
.New_Date = vbNullString
Case Is = "Hide"
.Option3M.Visible = False
.Option6M.Visible = False
.Option12M.Visible = False
.Rego_3M = vbNullString
.Rego_6M = vbNullString
.Rego_12M = vbNullString
.New_Date = vbNullString
Case Else
.Rego_3M.Caption = DateAdd("m", 3, NewVal)
.Option3M.Visible = True
.Rego_6M.Caption = DateAdd("m", 6, NewVal)
.Option6M.Visible = True
.Rego_12M.Caption = DateAdd("m", 12, NewVal)
.Option12M.Visible = True
End Select
End With
End Function