I have created an Inventory Management System for my company, using an Excel UserForm.
It is supposed to take the following inputs:
Product Type: Dropdown
Product Name: Dropdown
Date of Storage: Text Box
Sourced From: Dropdown
Stored In: Dropdown
Label: Text Box
Storage Location: Dropdown
Weight: Text Box
These are columns 1 to 8 in a subsheet Data_Entries. There are 35 further columns in the subsheet, that I together call GLC_Headers (since they give data on chromatography for each product). My userform has to dynamically show the relevant data headers out of the 35 and populate them, based on the Product Type. The relevant data headers have been stored in another hidden subsheet GLC_Headers for the code to refer to.
The UserForm needs to have the functionalities of adding an entry, modifying and deleting the entry (the row will be found by Label value). The modification, deletion history is saved to a History_Values Sheet.
I have attached an image of the userform layout for your reference, and here is the code:
UserForm Code:
Private Sub UserForm_Initialize()
' Initialize ComboBoxes
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Sheets("Data_Entries")
Call PopulateComboBox(Me.cboSourcedFrom, wsData.Columns(4))
Call PopulateComboBox(Me.cboStoredIn, wsData.Columns(5))
Call PopulateComboBox(Me.cboProductName, wsData.Columns(2))
Call PopulateComboBox(Me.cboProductType, wsData.Columns(1))
Call PopulateComboBox(Me.cboStorageLocation, wsData.Columns(7))
Debug.Print ("Initializing....")
' Populate GLC Headers
Dim glcHeaders As Collection
Set glcHeaders = GetGLCHeaders
Call PopulateGLCFrame(glcHeaders)
End Sub
Private Sub btnSaveEntry_Click()
' Validate Form Data
If Not ValidateFormData(Me) Then
MsgBox "Please fill all required fields before saving!", vbExclamation, "Validation Error"
Exit Sub
End If
' Save Data
If ValidateFormData(Me) Then
Call SaveEntry(Me)
End If
' Confirmation
MsgBox "Entry Saved Successfully!", vbInformation, "Success"
End Sub
Private Sub PopulateGLCFrame(headers As Collection)
Dim i As Integer
Dim currentColumn As Integer
Dim currentRow As Integer
Dim ctrlTop As Single
Dim ctrlLeft As Single
Dim lbl As Control
Dim txt As Control
' Clear existing controls in the frame
For Each ctrl In Me.fraGLCValues.Controls
Me.fraGLCValues.Controls.Remove ctrl.Name
Next ctrl
' Dimensions and settings
Dim columnWidth As Single: columnWidth = 150
Dim rowHeight As Single: rowHeight = 20
Dim fontSize As Single: fontSize = 8
Dim maxRowsPerColumn As Integer: maxRowsPerColumn = 12
' Initialize column and row trackers
currentColumn = 0
currentRow = 0
' Loop through headers and add controls dynamically
For i = 1 To headers.Count
' Calculate position
ctrlTop = currentRow * rowHeight
ctrlLeft = currentColumn * columnWidth
' Add Label
Set lbl = Me.fraGLCValues.Controls.Add("Forms.Label.1", "lblGLC_" & i)
lbl.Caption = headers(i)
lbl.Left = ctrlLeft
lbl.Top = ctrlTop
lbl.Width = 75
lbl.Height = rowHeight
lbl.Font.Size = fontSize
' Add TextBox
Set txt = Me.fraGLCValues.Controls.Add("Forms.TextBox.1", "txtGLC_" & headers(i))
txt.Left = ctrlLeft + 75
txt.Top = ctrlTop
txt.Width = 75
txt.Height = rowHeight
txt.Font.Size = fontSize
' Update row/column trackers
currentRow = currentRow + 1
If currentRow >= maxRowsPerColumn Then
currentRow = 0
currentColumn = currentColumn + 1
End If
Next i
End Sub
Private Sub btnDeleteEntry_Click()
Call DeleteEntry(Me)
End Sub
Private Sub btnModifyEntry_Click()
Call ModifyEntry(Me)
End Sub
Helper Module Code:
Sub PopulateComboBox(cbo As ComboBox, rng As Range)
Dim cell As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For Each cell In rng
If Not IsEmpty(cell.Value) And Not dict.exists(cell.Value) Then
dict.Add cell.Value, Nothing
cbo.AddItem cell.Value
End If
Next cell
End Sub
Function GetGLCHeaders() As Collection
Dim ws As Worksheet
Dim headers As Collection
Dim cell As Range
Set ws = ThisWorkbook.Sheets("GLC_Headers")
Set headers = New Collection
For Each cell In ws.UsedRange.Columns(1).Cells
If Not IsEmpty(cell.Value) Then headers.Add cell.Value
Next cell
Set GetGLCHeaders = headers
End Function
Function ValidateFormData(frmInventory As Object) As Boolean
ValidateFormData = True
' Validate required fields
If frmInventory.cboProductType.Value = "" Then ValidateFormData = False
If frmInventory.cboProductName.Value = "" Then ValidateFormData = False
If frmInventory.txtDateOfStorage.Value = "" Then ValidateFormData = False
If frmInventory.cboSourcedFrom.Value = "" Then ValidateFormData = False
If frmInventory.cboStoredIn.Value = "" Then ValidateFormData = False
If frmInventory.txtLabel.Value = "" Then ValidateFormData = False
If frmInventory.cboStorageLocation.Value = "" Then ValidateFormData = False
If frmInventory.txtWeight.Value = "" Then ValidateFormData = False
' Show error message if validation fails
If Not ValidateFormData Then
MsgBox "Please fill in all required fields before proceeding.", vbExclamation, "Validation Error"
End If
End Function
Sub SaveEntry(frmInventory As Object)
Dim ws As Worksheet
Dim newRow As Long
' Set the Data_Entries worksheet
Set ws = ThisWorkbook.Sheets("Data_Entries")
' Find the next available row
newRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
' Add data to the worksheet
ws.Cells(newRow, 1).Value = frmInventory.cboProductType.Value ' Product Type
ws.Cells(newRow, 2).Value = frmInventory.cboProductName.Value ' Product Name
ws.Cells(newRow, 3).Value = Format(frmInventory.txtDateOfStorage.Value, "DD/MM/YYYY") ' Date of Storage
ws.Cells(newRow, 4).Value = frmInventory.cboSourcedFrom.Value ' Sourced From
ws.Cells(newRow, 5).Value = frmInventory.cboStoredIn.Value ' Stored In
ws.Cells(newRow, 6).Value = frmInventory.txtLabel.Value ' Label
ws.Cells(newRow, 7).Value = frmInventory.cboStorageLocation.Value ' Storage Location
ws.Cells(newRow, 8).Value = frmInventory.txtWeight.Value ' Weight
' Add GLC values dynamically
Dim header As Range, i As Integer
i = 9 ' Start column for GLC headers
For Each header In ws.Rows(1).Cells
If header.Value <> "" And Not IsEmpty(frmInventory.Controls("txtGLC_" & header.Value)) Then
ws.Cells(newRow, i).Value = frmInventory.Controls("txtGLC_" & header.Value).Value
i = i + 1
End If
Next header
' Confirmation message
MsgBox "Entry added successfully!", vbInformation, "Success"
End Sub
Sub LogHistory(actionType As String, originalData As Variant)
Dim wsHistory As Worksheet
Dim newRow As Long
' Create History_Entries sheet if it doesn't exist
On Error Resume Next
Set wsHistory = ThisWorkbook.Sheets("History_Entries")
On Error GoTo 0
If wsHistory Is Nothing Then
Set wsHistory = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsHistory.Name = "History_Entries"
wsHistory.Cells(1, 1).Value = "Timestamp"
wsHistory.Cells(1, 2).Value = "Action"
wsHistory.Cells(1, 3).Value = "Original Data"
End If
' Determine next empty row
newRow = wsHistory.Cells(wsHistory.Rows.Count, 1).End(xlUp).Row + 1
' Log the action
With wsHistory
.Cells(newRow, 1).Value = Now ' Current timestamp
.Cells(newRow, 2).Value = actionType
.Cells(newRow, 3).Value = Join(originalData, ", ") ' Combine original data into one cell
End With
End Sub
Sub ModifyEntry(frmInventory As Object)
Dim ws As Worksheet, historyWs As Worksheet
Dim labelToFind As String
Dim foundRow As Long
Dim newRow As Long
Dim i As Integer
Dim header As Range
' Set the Data_Entries and History worksheets
Set ws = ThisWorkbook.Sheets("Data_Entries")
Set historyWs = ThisWorkbook.Sheets("History_Entries")
' Get the label to search for
labelToFind = InputBox("Please enter the label of the entry to modify:", "Enter Label")
' Find the row with the matching label
On Error Resume Next
foundRow = Application.Match(labelToFind, ws.Range("F:F"), 0) ' Assuming 'Label' is in column F
On Error GoTo 0
If foundRow = 0 Then
MsgBox "Label not found in the database.", vbExclamation, "Error"
Exit Sub
End If
' Save the original data to the history sheet
newRow = historyWs.Cells(historyWs.Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To ws.Columns.Count
historyWs.Cells(newRow, i).Value = ws.Cells(foundRow, i).Value
Next i
' Update the data in the Data_Entries sheet
ws.Cells(foundRow, 1).Value = frmInventory.cboProductType.Value ' Product Type
ws.Cells(foundRow, 2).Value = frmInventory.cboProductName.Value ' Product Name
ws.Cells(foundRow, 3).Value = Format(frmInventory.txtDateOfStorage.Value, "DD/MM/YYYY") ' Date of Storage
ws.Cells(foundRow, 4).Value = frmInventory.cboSourcedFrom.Value ' Sourced From
ws.Cells(foundRow, 5).Value = frmInventory.cboStoredIn.Value ' Stored In
ws.Cells(foundRow, 6).Value = frmInventory.txtLabel.Value ' Label
ws.Cells(foundRow, 7).Value = frmInventory.cboStorageLocation.Value ' Storage Location
ws.Cells(foundRow, 8).Value = frmInventory.txtWeight.Value ' Weight
' Update GLC values dynamically
i = 9 ' Start column for GLC headers
For Each header In ws.Rows(1).Cells
If header.Value <> "" And Not IsEmpty(frmInventory.Controls("txtGLC_" & header.Value)) Then
ws.Cells(foundRow, i).Value = frmInventory.Controls("txtGLC_" & header.Value).Value
i = i + 1
End If
Next header
' Confirmation message
MsgBox "Entry modified successfully!", vbInformation, "Success"
End Sub
Sub DeleteEntry(frmInventory As Object)
Dim ws As Worksheet, historyWs As Worksheet
Dim labelToFind As String
Dim foundRow As Long
Dim newRow As Long
Dim i As Integer
' Set the Data_Entries and History worksheets
Set ws = ThisWorkbook.Sheets("Data_Entries")
Set historyWs = ThisWorkbook.Sheets("History_Entries")
' Get the label to search for
labelToFind = InputBox("Please enter the label of the entry to modify:", "Enter Label")
' Find the row with the matching label
On Error Resume Next
foundRow = Application.Match(labelToFind, ws.Range("F:F"), 0) ' Assuming 'Label' is in column F
On Error GoTo 0
If foundRow = 0 Then
MsgBox "Label not found in the database.", vbExclamation, "Error"
Exit Sub
End If
' Save the original data to the history sheet
newRow = historyWs.Cells(historyWs.Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To ws.Columns.Count
historyWs.Cells(newRow, i).Value = ws.Cells(foundRow, i).Value
Next i
' Delete the row from the Data_Entries sheet
ws.Rows(foundRow).Delete
' Confirmation message
MsgBox "Entry deleted successfully!", vbInformation, "Success"
End Sub
I tried running the UserForm on VBA using frmInventory.Show, but it showed Error 5: (Runtime Error): Invalid Procedure Call or Argument.
I am unable to find the error. The form is not running from a button either, that is linked to a function that refers frmInventory.Show
Please help me fix this and understand how I can refine my code for the next time, since I am a beginner at VBA.
Your error is being thrown in sub PopulateComboBox. You are referencing the Value property in range cell however that property does not exist. You need to reference the Value2 property instead. You should also NEVER use reserved words such as cell to name a variable in your code. That is just asking for no end of trouble. And equally important, you should get into the habit of having Option Explicit as the first line in each module and class. This forces all variables to be declared and can save you an enormous amount of debug time. You can have the VB Editor do this for you automatically by going into Tools->Options. On the Editor tab check the Code Setting for Require Variable Declaration.
I have rewritten your sub to correct your issue as well as your logic. Please see below. One final point. You should review the dictionary object dict as it appears to be redundant. It is declared locally, populated, and never used.
Sub PopulateComboBox(cbo As ComboBox, rng As Range)
Dim varCell As Variant
Dim dict As Object
Dim lngLoop As Long
Set dict = CreateObject("Scripting.Dictionary")
With rng
' Store all the values in an array
varCell = .Cells.Value2
' Only process cells with a value and stop when the last row containing data
' is reached, otherwise we loop through 1 million+ times. Not good from a
' performance perspective.
For lngLoop = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If varCell(lngLoop, 1) <> "" And Not dict.exists(varCell(lngLoop, 1)) Then
dict.Add varCell(lngLoop, 1), Nothing
cbo.AddItem varCell(lngLoop, 1)
End If
Next
End With
End Sub