Sleeper: Dependent lists in order to restrict choices

I am trying to create dependent lists in order to restrict users to select only from a drop-down list. For example using Category, Type and Item (CTI):

Category: Hardware and Software.

Hardware Type: Server, Workstation or Peripheral

Software Type: OS, Boxed Application or Developed Software

Items for Workstation Type: Laptop, Desktop, Palmtop
Items for Peripheral Type: Printer, Screen, Scanner, Modem
and the list grows on ...

What should happen is that when a user select Category - Hardware, the user should only be able to select Server, Workstation or Peripheral in the Type drop-down list. When the Type Peripheral is selected the user should only be able to select Printer, Screen, Scanner or Modem in the Item list.

I have found instructions on http://www.contextures.com/xlDataVol02.html how to set up such a list but it does not work they way we want it to work.

One should be able via VBA code and a change event on the drop-down list to do this. Manually creating filters works 100% but we want to use drop-downs. Anybody done this before? Can you perhaps point me to a page for an example?

Barry,
Do you want this to be done entirely in code, or do you have a sheet that lists all the options?
Matt

The reason I asked that is if you're doing this all via code (an incredibly easy way to manage it), you could do it like:

Code:

---

Private Sub UserForm_Initialize()
ComboBox1.Text = "Select Category"
ComboBox1.List = GetChoices("Category")
End Sub

Private Sub ComboBox1_Click() '_Change()
ComboBox2.Text = "Select Type"
ComboBox2.List = GetChoices(ComboBox1.Value)
End Sub

Private Sub ComboBox2_Click() '_Change()
ComboBox3.Text = "Select Item"
ComboBox3.List = GetChoices(ComboBox2.Value)
End Sub

Function GetChoices(ByRef vChoice As String) As Variant()
Dim TempArr() As Variant
Select Case vChoice
Case "Category": TempArr = Array("Hardware", "Software")
Case "Hardware": TempArr = Array("Server", "Workstation", "Peripheral")
Case "Software": TempArr = Array("OS", "Boxed Application", "Developed Software")
Case "Workstation": TempArr = Array("Laptop", "Desktop", "Palmtop")
Case "Peripheral Type": TempArr = Array("Printer", "Screen", "Scanner", "Modem")
End Select
GetChoices = TempArr
End Function

---

I used a userform to test this, but if you're doing it on a sheet, just change the userform_initialize to whatever you're going to use to populate the first combobox.

I'll attach the file I made this sample in, feel free to adapt and/or ask any questions you may have! All you have to do is update the GetChoices function with all choices you have.

Matt

This is basically the right idea! (Sorry EXACTLY what is required!)
I will play with your code tonight to see how I can panel beat it to suit my application.

This way the structure is hard coded, but what if a non VBA coder needs to change an entry or add more items to the list? That is why I need to select from a list, but in the way your userform presents it. (Alternatively an Administrator with a pwd should have extra functions available to add to arrays if the code stays hard coded.

I have included my file to see exactly how the data look like that we want to use as lookups for a UserForm to populate a BaseAsset sheet.

If you're working from a list (like your CTI sheet), it will be easier for others to add items. I wasn't sure of your setup, but now that I know I can customize it better for you.
I am still curious about one thing, where are you going to put the comboboxes (or would you prefer listboxes?)? That will affect a couple small things in the code, but I'll give you the code as if you were using a userform, and we can adapt as necessary once I find out where the boxes will be.
I'm attaching an updated file, I moved the userform and worksheet from my sample file to yours, and changed the userform code to:

Code:

---

Private Sub UserForm_Initialize()
ComboBox1.Text = "Select Category"
ComboBox1.List = GetCategories
End Sub

Private Sub ComboBox1_Click()
ComboBox2.Text = "Select Type"
ComboBox2.List = GetType(ComboBox1.Value)
End Sub

Private Sub ComboBox2_Click()
ComboBox3.Text = "Select Item"
ComboBox3.List = GetItem(ComboBox2.Value)
End Sub

Function GetCategories() As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = Intersect(Sheets("CTI").Range("A6:A65536"), Sheets("CTI").UsedRange)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetCategories = TempArr
End Function

Function GetType(ByVal vCategory As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("CTI").Range("A6:A65536"), vCategory).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetType = TempArr
End Function

Function GetItem(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("CTI").Range("B6:B65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetItem = TempArr
End Function

Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
Dim FND As Range, FND1 As Range
Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlWhole)
If Not FND Is Nothing Then
Set FoundRange = FND: Set FND1 = FND: Set FND = vRG.FindNext(FND)
Do Until FND.Address = FND1.Address
Set FoundRange = Union(FoundRange, FND): Set FND = vRG.FindNext(FND)
Loop
End If
End Function

Function InSArr(ByRef vArray() As String, ByVal vItem As String) As Long
Dim i As Long, iUB As Long
iUB = UBound(vArray)
For i = 0 To iUB
If vArray(i) = vItem Then
InSArr = i
Exit Function
End If
Next 'i
InSArr = -1
End Function

---

This way all you have to do is update the CTI sheet and the dropdowns will be updated automatically. If you're having trouble converting it to how you want it, let me know more of what you want and I'll give you a hand!
Matt

Matt

I must thank you over and over as you do not realise how much you have helped me! I am not a programmer, but a good code panel beater if you get my drift.

For now the first userform opens when the workbook is opened
Code force user to stay on the same row when populating the sheet
Still needs to be done: Check for duplicate names and serial numbers and prevent user entry if true.

Below the result of the new code: (Also see attchment for current operation)

Code:

---

Public curRow      'Declare global variable (Used to check row)
Sub Auto_Open()  'Autorun code the moment workbook is opened
Userform1.Show  'Run macro within a macro by using the call statement
End Sub

Private Sub UserForm_Activate()
Range("D7").Select                                  'Select Location start cell
ActiveCell.Offset(0, 0).Select
Selection.End(xlDown).Select                        'Move to last data cell
ActiveCell.Offset(1, 0).Select                      'Move 1 row down to empty cell
curRow = ActiveCell.Row
myRow = curRow
myCol = ActiveCell.Column
If myCol <> 4 Then
MsgBox "Wrong Column - Please move to Column D"
Userform1.Hide
Exit Sub
End If
End Sub

Private Sub UserForm_Initialize()
ComboBox1.Text = "Select Category"
ComboBox1.List = GetCategories
End Sub

Private Sub ComboBox1_Click()
ComboBox2.Text = "Select Type"
ComboBox2.List = GetType(ComboBox1.Value)
End Sub

Private Sub ComboBox2_Click()
ComboBox3.Text = "Select Item"
ComboBox3.List = GetItem(ComboBox2.Value)
End Sub

Private Sub ComboBox3_Change()
End Sub

Private Sub CommandButton1_Click()
If ComboBox3.Value = "" Then Exit Sub
ActiveCell.Offset(0, 0).Select
ActiveCell.FormulaR1C1 = UCase(ComboBox1.Value)    'Write Category
ActiveCell.Offset(0, 1).Select                      'Select next right empty cell
ActiveCell.FormulaR1C1 = UCase(ComboBox2.Value)    'Write Type
ActiveCell.Offset(0, 1).Select                      'Select next right empty cell
ActiveCell.FormulaR1C1 = UCase(ComboBox3.Value)    'Write Item
ActiveCell.Offset(0, 1).Select                      'Select next right empty cell
myRow = ActiveCell.Row
myCol = ActiveCell.Column
Userform1.Hide
ActiveCell.EntireRow.Select
ActiveCell.Interior.ColorIndex = xlNone
With Selection.Interior
    .ColorIndex = 44
    .Pattern = xlSolid
End With
CDQ = Chr(32)
Application.Goto Reference:=CDQ & "R" & myRow & "C" & myCol & CDQ
End Sub

Function GetCategories() As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = Intersect(Sheets("CTI").Range("A6:A65536"), Sheets("CTI").UsedRange)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetCategories = TempArr
End Function

Function GetType(ByVal vCategory As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("CTI").Range("A6:A65536"), vCategory).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetType = TempArr
End Function

Function GetItem(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("CTI").Range("B6:B65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetItem = TempArr
End Function

Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
Dim FND As Range, FND1 As Range
Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlWhole)
If Not FND Is Nothing Then
Set FoundRange = FND: Set FND1 = FND: Set FND = vRG.FindNext(FND)
Do Until FND.Address = FND1.Address
Set FoundRange = Union(FoundRange, FND): Set FND = vRG.FindNext(FND)
Loop
End If
End Function

Function InSArr(ByRef vArray() As String, ByVal vItem As String) As Long
Dim i As Long, iUB As Long
iUB = UBound(vArray)
For i = 0 To iUB
If vArray(i) = vItem Then
InSArr = i
Exit Function
End If
Next
InSArr = -1
End Function

Private Sub UserForm_Activate()
Range("N7").Select                                  'Select Location Information start cell
ActiveCell.Offset(0, 0).Select
Selection.End(xlDown).Select                        'Move to last cell containing data
ActiveCell.Offset(1, 0).Select                      'Move 1 row down to empty cell
myRow = ActiveCell.Row
'ENSURE THAT ENTRIES ARE POPULATED IN THE SAME ROW!
While curRow <> myRow
If curRow > myRow Then
ActiveCell.Offset(1, 0).Select
myRow = ActiveCell.Row
End If
If curRow < myRow Then
ActiveCell.Offset(-1, 0).Select
myRow = ActiveCell.Row
End If
Wend
myCol = ActiveCell.Column
If myCol <> 14 Then
MsgBox "Wrong Column - Please move to Column N"
UserForm2.Hide
Exit Sub
End If
End Sub

Private Sub UserForm_Initialize()
ComboBox10.Text = "Select Service Provider"
ComboBox10.List = GetServiceProvider
End Sub
Private Sub ComboBox10_Click()
ComboBox11.Text = "Select Company"
ComboBox11.List = GetCompany(ComboBox10.Value)
End Sub

Private Sub ComboBox11_Click()
ComboBox12.Text = "Select Client name"
ComboBox12.List = GetClientName(ComboBox11.Value)
End Sub

Private Sub ComboBox12_Click()
ComboBox13.Text = "Select Client Site"
ComboBox13.List = GetClientSite(ComboBox12.Value)
End Sub
Private Sub ComboBox13_Click()
ComboBox14.Text = "Select Client Region"
ComboBox14.List = GetClientRegion(ComboBox13.Value)
End Sub

Private Sub ComboBox14_Click()
ComboBox15.Text = "Select Client Department"
ComboBox15.List = GetDepartment(ComboBox14.Value)
End Sub

Private Sub CommandButton1_Click()
If ComboBox14.Value = "" Then Exit Sub
If ComboBox14.Value = "Select Department" Then Exit Sub
ActiveCell.Offset(0, 0).Select
ActiveCell.FormulaR1C1 = UCase(ComboBox10.Value)    'Write Serv Provider
ActiveCell.Offset(0, 1).Select                      'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox11.Value)    'Write Company
ActiveCell.Offset(0, 1).Select                      'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox12.Value)    'Write Client Name
ActiveCell.Offset(0, 1).Select                      'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox13.Value)    'Write Client Site
ActiveCell.Offset(0, 1).Select                      'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox14.Value)    'Write Client region
ActiveCell.Offset(0, 1).Select                      'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox15.Value)    'Write Client Department
ActiveCell.Offset(0, 1).Select                      'Select next empty cell to the right
myCol = ActiveCell.Column
myRow = ActiveCell.Row
UserForm2.Hide
ActiveCell.EntireRow.Select                        'Select entire row
ActiveCell.Interior.ColorIndex = xlNone
With Selection.Interior
      .ColorIndex = 37                            'Change row colour
      .Pattern = xlSolid
End With
CDQ = Chr(32)
Application.Goto Reference:=CDQ & "R" & myRow & "C" & myCol & CDQ 'Go back to empty cell
End Sub

Function GetServiceProvider() As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = Intersect(Sheets("Locations").Range("A8:A65536"), Sheets("Locations").UsedRange)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetServiceProvider = TempArr
End Function

Function GetCompany(ByVal vCategory As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("A8:A65536"), vCategory).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetCompany = TempArr
End Function

Function GetClientName(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("B8:B65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetClientName = TempArr
End Function

Function GetClientSite(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("C8:C65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetClientSite = TempArr
End Function

Function GetClientRegion(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("D8:D65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetClientRegion = TempArr
End Function

Function GetDepartment(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("E8:E65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetDepartment = TempArr
End Function

Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
Dim FND As Range, FND1 As Range
Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlWhole)
If Not FND Is Nothing Then
Set FoundRange = FND: Set FND1 = FND: Set FND = vRG.FindNext(FND)
Do Until FND.Address = FND1.Address
Set FoundRange = Union(FoundRange, FND): Set FND = vRG.FindNext(FND)
Loop
End If
End Function

Function InSArr(ByRef vArray() As String, ByVal vItem As String) As Long
Dim i As Long, iUB As Long
iUB = UBound(vArray)
For i = 0 To iUB
If vArray(i) = vItem Then
InSArr = i
Exit Function
End If
Next 'i
InSArr = -1
End Function

---