Userform Validation - Unique Names & Numbers

[youngmcc]

Hi,

I am wondering if anyone can help.

I have four data lists in a worksheet consisting of people, F1 drivers, qualifying positions and finishing positions.

In my userform, I have:

24 combo boxes relating to Name,
24 combo boxes relating to Driver Name,
24 combo boxes relating to Qualifying Position and
24 combo boxes relating to Finishing Position

I basically want validation on my userform so that once I select a Name, that name is no longer available to select in the remaining 23 combo boxes.

Basically, so its only unique values that are left everytime I draw out a new driver etc.

So as an example.

cboName1 has a value of Driver1
cboDriver1 has a value of Sebastian Vettel
cboQF1 has a value of 1

So in all the other cboName() combo boxes Driver1 will no longer be available selection and in all the other cboDriver() combo boxes Sebastian Vettel will no longer be available for selection

Example book and userform is attached.

Cheers

McC

[GTO]

So as an example.

cboName1 has a value of Driver1
cboDriver1 has a value of Sebastian Vettel
cboQF1 has a value of 1

So in all the other cboName() combo boxes Driver1 will no longer be available selection and in all the other cboDriver() combo boxes Sebastian Vettel will no longer be available for selection

Greetings McC,

Welcome to vbaexpress!

I am not quite understanding maybe... If you are wanting to keep records together, such as Driver1 refers to Sebastian Vettel, and presumably the QF and Finish of 1 both go with this record... why not have one combo box that has multiple columns?

Am I missing something?

Mark

[youngmcc]

Greetings McC,

Welcome to vbaexpress!

I am not quite understanding maybe... If you are wanting to keep records together, such as Driver1 refers to Sebastian Vettel, and presumably the QF and Finish of 1 both go with this record... why not have one combo box that has multiple columns?

Am I missing something?

Mark

Hi Mark,

Thanks for the welcome.

These records are unrelated.

Basically its a fantasy F1 draw so I will start by drawing out the first persons name out a hat and select their name from the combo box.

I will then draw out the drivers name and select their name in Drivers Name combo box.

When I come onto the second row of combo boxes, I basically want the list to be refreshed so that I cannot select the previous name or drivers name due to them already being out the hat.

Its really just another form of validation so that when I get to the last combo box I am only left with the remaining name in the hat along with the remaining driver.

Any ideas?

Thanks

[GTO]

Okay, sorry for being thick-headed, but I want to make sure I understand:

So in all the other cboName() combo boxes Driver1 will no longer be available selection and in all the other cboDriver() combo boxes Sebastian Vettel will no longer be available for selection

So, if I pick Driver 1, do I just want to elminate Driver 1 in the remainder of combo boxes in that 'column', but Sebastian (that is, all 24 driver names) would still be available, until a driver name is picked in a combo box in that 'column'?

Thanks,

Mark

[youngmcc]

Okay, sorry for being thick-headed, but I want to make sure I understand:

So in all the other cboName() combo boxes Driver1 will no longer be available selection and in all the other cboDriver() combo boxes Sebastian Vettel will no longer be available for selection

So, if I pick Driver 1, do I just want to elminate Driver 1 in the remainder of combo boxes in that 'column', but Sebastian (that is, all 24 driver names) would still be available, until a driver name is picked in a combo box in that 'column'?

Thanks,

Mark

Hi Mark,

That is exactly correct.

The same applies to the Qualifying and Finishing position columns.

So if the first two combo boxes in the Drivers Name column is Vettel and Hamilton, these two names are unavailable in the next 22 combo boxes in that column.

Thanks again for your help

McC

[GTO]

Well, I ran out of time today and am trying to do this with a class, which I am just not 'getting' yet. I'll try again tonight.

[youngmcc]

Well, I ran out of time today and am trying to do this with a class, which I am just not 'getting' yet. I'll try again tonight.

No worries.

Thanks for your help kind sir.

I look forward to seeing your solution.

[BrianMH]

Sorry GTO if you are already working on a solution. Well only kind of you may end up with a better one. I was bored and figured I would have a go.

Any way I have attached my solution as a workbook. It uses the mouse move event to constantly update the combo list options based on what is in the others. You could use the click event of each one but you would need to put the call for each individual box and that seemed long. Hope that helps

Workbook is attached and code is below.

edit: btw I had to remove the rowsource that you had on all your comboboxes as my code adds each item as necessary.

Option Base 1
Option Explicit
Public arrPerson
Public arrDriver
Public arrQualPos
Public arrFinPos
Public arrUsed





Private Sub cboName1_Change()

End Sub

Private Sub UserForm_Initialize()
Dim stData As Worksheet
Dim intRows As Integer
Dim x As Integer
Dim c As Range
Set stData = ThisWorkbook.Sheets("Data")
intRows = stData.Range("Person").Rows.Count
ReDim arrPerson(intRows)
ReDim arrDriver(intRows)
ReDim arrQualPos(intRows)
ReDim arrFinPos(intRows)
ReDim arrUsed(intRows)
x = 1
For Each c In stData.Range("Person").Cells
arrPerson(x) = c.Value
x = x + 1
Next

x = 1
For Each c In stData.Range("Driver").Cells
arrDriver(x) = c.Value
x = x + 1
Next

For x = 1 To intRows
arrQualPos(x) = x
arrFinPos(x) = x
Next

End Sub


Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Call UpdateDropDowns
End Sub

Private Sub UpdateDropDowns()
Dim c
Dim x As Integer
Dim test As Boolean
x = 1
For Each c In Me.Controls
If c.Name Like "cbo*" Then
For x = 1 To c.ListCount
c.RemoveItem 0

Next
End If
Next

x = 1
For Each c In Me.Controls
If c.Name Like "cboName*" Then
arrUsed(x) = c.Value
x = x + 1
End If
Next c

For Each c In Me.Controls
If c.Name Like "cboName*" Then
For x = 1 To UBound(arrPerson)
If fnInArray(arrPerson(x), arrUsed) = False Then
c.AddItem arrPerson(x)
End If
Next x
End If
Next c
x = 1
For Each c In Me.Controls
If c.Name Like "cboDriver*" Then
arrUsed(x) = c.Value
x = x + 1
End If
Next c

For Each c In Me.Controls
If c.Name Like "cboDriver*" Then

For x = 1 To UBound(arrDriver)
If fnInArray(arrDriver(x), arrUsed) = False Then
c.AddItem arrDriver(x)
End If
Next x
End If
Next c
x = 1
For Each c In Me.Controls
If c.Name Like "cboQF*" Then
arrUsed(x) = c.Value
x = x + 1
End If
Next c

For Each c In Me.Controls
If c.Name Like "cboQF*" Then

For x = 1 To UBound(arrQualPos)
If fnInArray(arrQualPos(x), arrUsed) = False Then
c.AddItem arrQualPos(x)
End If
Next x
End If
Next c
x = 1
For Each c In Me.Controls
If c.Name Like "cboFin*" Then
arrUsed(x) = c.Value
x = x + 1
End If
Next c

For Each c In Me.Controls
If c.Name Like "cboFin*" Then

For x = 1 To UBound(arrFinPos)
If fnInArray(arrFinPos(x), arrUsed) = False Then
c.AddItem arrFinPos(x)
End If
Next x
End If
Next c

End Sub

Private Function fnInArray(Test_value, arrTest As Variant) As Boolean
Dim bltest As Boolean
bltest = False
Dim i As Integer
For i = 1 To UBound(arrTest)
If CStr(Test_value) = CStr(arrTest(i)) Then
bltest = True
End If
Next i
fnInArray = bltest
End Function

[youngmcc]

Hi Brian,

Thanks for the reply.
I've had a look at the code and it looks great.

Is it possible for you to explain a bit more about the Click Event and how the code would be structured for that?

Is it possible to run this code from a combobox_change point of you?

thanks

McC

[BrianMH]

Yeah if you wanted to do it on the change event you would need to add event code for each combobox. You would simply add call UpdateDropDowns for each combobox update event. You would also probably want to add that call to the initialize event. It's that call that does the updating of what is available in dropdowns. Don't forget to remove your rowsource links (might be easier just to export my form and import it into your workbook). It would work the same for any event. It just changes when it updates.

edit: btw this does count on your naming convention of the comboboxes. So don't go changing that unless you want to edit the code in quite a few places :).

[youngmcc]

Yeah if you wanted to do it on the change event you would need to add event code for each combobox. You would simply add call UpdateDropDowns for each combobox update event. You would also probably want to add that call to the initialize event. It's that call that does the updating of what is available in dropdowns. Don't forget to remove your rowsource links (might be easier just to export my form and import it into your workbook). It would work the same for any event. It just changes when it updates.

edit: btw this does count on your naming convention of the comboboxes. So don't go changing that unless you want to edit the code in quite a few places :).

Hi Brian,

I have amended the code to add in the call procedure to the end of the intiliaze and also added the call for each of the update events.

I have removed the Finishing Position column as I don’t actually need this for the draw. The code works fine with the mouse over event, however, I am receiving an error on the change event.

Runtime Error -2147467259 (80004005)

It seems to debug on the line:

c.RemoveItem 0

I have attached the amended workbook.
Is anyone able to advise on how to fix this problem?

The rest of the code is great. Thanks very much.

Cheers
McC

[GTO]

Hi again McC and Howdy Brian as well :hi:


Sorry GTO if you are already working on a solution. Well only kind of you may end up with a better one. I was bored and figured I would have a go...

No apologies; IMO, this is one of the great things about vbax. We get to see different ways of 'skinning the cat'.


Well, I ran out of time today and am trying to do this with a class, which I am just not 'getting' yet. I'll try again tonight.

Well... the "not 'getting' it" turned out to be awfully lengthy, but other than a small fire and lights occassionally dimming when F5 was pushed...

Okay, here's probably my first stab at using a class without following someone's example. I greatly suspect that efficiency and/or better localizing of the dictionaries could be accomplished, but it seems tobe working. (I am trying not to sound suprised, but was getting awfully frustrated for a bit.)

In a Class Module named clsPerson:

Option Explicit

Public WithEvents PersonGroup As MSForms.ComboBox

Function UpdateUsed(fra As MSForms.Frame, dic As Object)
Dim cbo As MSForms.ComboBox
Dim i As Long
Dim ary As Variant

DicUsed.RemoveAll
For Each cbo In fra.Controls
If Not cbo.ListIndex = -1 And Not cbo.Value = vbNullString Then
DicUsed.Item(cbo.Value) = cbo.Value
End If
Next
ary = dic.Keys
DicTmp.RemoveAll
For i = LBound(ary) To UBound(ary)
If Not DicUsed.Exists(CStr(ary(i))) Then DicTmp.Item(CStr(ary(i))) = CStr(ary(i))
Next
End Function

Private Sub PersonGroup_Change()
Dim ctl As MSForms.Control
Dim fra As MSForms.Frame

Set ctl = PersonGroup

Select Case True
Case ctl.Name Like "cboName*"
Set fra = frmDrawResults.fraName
Call UpdateUsed(fra, DicName)
Call UpdateLists(fra)
Case ctl.Name Like "cboDriver*"
Set fra = frmDrawResults.fraDriver
Call UpdateUsed(fra, DicDriver)
Call UpdateLists(fra)
Case ctl.Name Like "cboQF*"
Set fra = frmDrawResults.fraQF
Call UpdateUsed(fra, DicQF)
Call UpdateLists(fra)
Case ctl.Name Like "cboFin*"
Set fra = frmDrawResults.fraFin
Call UpdateUsed(fra, DicFin)
Call UpdateLists(fra)
End Select
End Sub

Function UpdateLists(fra As MSForms.Frame)
Dim tmpVal As String
Dim cbo As MSForms.ComboBox

If Not PersonGroup.ListIndex = -1 And Not PersonGroup.Value = vbNullString Then
tmpVal = PersonGroup.Value
If DicTmp.Exists(PersonGroup.Value) Then DicTmp.Remove (PersonGroup.Value)
PersonGroup.List = DicTmp.Keys
PersonGroup.AddItem tmpVal, 0
PersonGroup.ListIndex = 0
Else
PersonGroup.List = DicTmp.Keys
PersonGroup.ListIndex = -1
End If

For Each cbo In fra.Controls
If Not cbo.Name = PersonGroup.Name Then
If Not cbo.ListIndex = -1 And Not cbo.Value = vbNullString Then
tmpVal = cbo.Value
cbo.List = DicTmp.Keys
cbo.AddItem tmpVal, 0
cbo.ListIndex = 0
Else
cbo.List = DicTmp.Keys
cbo.ListIndex = -1
End If
End If
Next
End Function

In a Standard Module:

Option Explicit

Public DicName As Object
Public DicDriver As Object
Public DicQF As Object
Public DicFin As Object
Public DicUsed As Object
Public DicTmp As Object

Dim PersonBox() As New clsPerson

Sub AutoShape1_Click()
Call PrepDialog
End Sub

Sub PrepDialog()
Dim _
cbo As MSForms.ComboBox, _
lPersonCount As Long, _
rng As Range, _
Cell As Range

Set DicName = CreateObject("Scripting.Dictionary")
Set DicDriver = CreateObject("Scripting.Dictionary")
Set DicQF = CreateObject("Scripting.Dictionary")
Set DicFin = CreateObject("Scripting.Dictionary")
Set DicUsed = CreateObject("Scripting.Dictionary")
Set DicTmp = CreateObject("Scripting.Dictionary")

Set rng = Sheet1.Range("Person")
For Each Cell In rng
DicName.Item(Cell.Value) = CStr(Cell.Value)
Next

Set rng = Sheet1.Range("Driver")
For Each Cell In rng
DicDriver.Item(Cell.Value) = CStr(Cell.Value)
Next

Set rng = Sheet1.Range("QFPos")
For Each Cell In rng
DicQF.Item(Cell.Value) = CStr(Cell.Value)
Next

Set rng = Sheet1.Range("FinPos")
For Each Cell In rng
DicFin.Item(Cell.Value) = CStr(Cell.Value)
Next

lPersonCount = 0
For Each cbo In frmDrawResults.fraName.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicName.Keys
Next

For Each cbo In frmDrawResults.fraDriver.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicDriver.Keys
Next

For Each cbo In frmDrawResults.fraQF.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicQF.Keys
Next

For Each cbo In frmDrawResults.fraFin.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicFin.Keys
Next

frmDrawResults.Show
End Sub

You will note that like Brian, I ditched the RowSource. I also used a Frame control around each group of ComboBoxes. While trying several different ways (mostly with remarkable failure), it struck me that just looping through the controls in the group would be faster than looping through all the controls on the form. If you don't like frames, you could use the Like statement in a larger sense than I did.

Hope this helps,

Mark

[BrianMH]

Try changing that line to


if c.value <> "" then c.RemoveItem 0

[youngmcc]

Hi again McC and Howdy Brian as well :hi:



No apologies; IMO, this is one of the great things about vbax. We get to see different ways of 'skinning the cat'.



Well... the "not 'getting' it" turned out to be awfully lengthy, but other than a small fire and lights occassionally dimming when F5 was pushed...

Okay, here's probably my first stab at using a class without following someone's example. I greatly suspect that efficiency and/or better localizing of the dictionaries could be accomplished, but it seems tobe working. (I am trying not to sound suprised, but was getting awfully frustrated for a bit.)

In a Class Module named clsPerson:

Option Explicit

Public WithEvents PersonGroup As MSForms.ComboBox

Function UpdateUsed(fra As MSForms.Frame, dic As Object)
Dim cbo As MSForms.ComboBox
Dim i As Long
Dim ary As Variant

DicUsed.RemoveAll
For Each cbo In fra.Controls
If Not cbo.ListIndex = -1 And Not cbo.Value = vbNullString Then
DicUsed.Item(cbo.Value) = cbo.Value
End If
Next
ary = dic.Keys
DicTmp.RemoveAll
For i = LBound(ary) To UBound(ary)
If Not DicUsed.Exists(CStr(ary(i))) Then DicTmp.Item(CStr(ary(i))) = CStr(ary(i))
Next
End Function

Private Sub PersonGroup_Change()
Dim ctl As MSForms.Control
Dim fra As MSForms.Frame

Set ctl = PersonGroup

Select Case True
Case ctl.Name Like "cboName*"
Set fra = frmDrawResults.fraName
Call UpdateUsed(fra, DicName)
Call UpdateLists(fra)
Case ctl.Name Like "cboDriver*"
Set fra = frmDrawResults.fraDriver
Call UpdateUsed(fra, DicDriver)
Call UpdateLists(fra)
Case ctl.Name Like "cboQF*"
Set fra = frmDrawResults.fraQF
Call UpdateUsed(fra, DicQF)
Call UpdateLists(fra)
Case ctl.Name Like "cboFin*"
Set fra = frmDrawResults.fraFin
Call UpdateUsed(fra, DicFin)
Call UpdateLists(fra)
End Select
End Sub

Function UpdateLists(fra As MSForms.Frame)
Dim tmpVal As String
Dim cbo As MSForms.ComboBox

If Not PersonGroup.ListIndex = -1 And Not PersonGroup.Value = vbNullString Then
tmpVal = PersonGroup.Value
If DicTmp.Exists(PersonGroup.Value) Then DicTmp.Remove (PersonGroup.Value)
PersonGroup.List = DicTmp.Keys
PersonGroup.AddItem tmpVal, 0
PersonGroup.ListIndex = 0
Else
PersonGroup.List = DicTmp.Keys
PersonGroup.ListIndex = -1
End If

For Each cbo In fra.Controls
If Not cbo.Name = PersonGroup.Name Then
If Not cbo.ListIndex = -1 And Not cbo.Value = vbNullString Then
tmpVal = cbo.Value
cbo.List = DicTmp.Keys
cbo.AddItem tmpVal, 0
cbo.ListIndex = 0
Else
cbo.List = DicTmp.Keys
cbo.ListIndex = -1
End If
End If
Next
End Function

In a Standard Module:

Option Explicit

Public DicName As Object
Public DicDriver As Object
Public DicQF As Object
Public DicFin As Object
Public DicUsed As Object
Public DicTmp As Object

Dim PersonBox() As New clsPerson

Sub AutoShape1_Click()
Call PrepDialog
End Sub

Sub PrepDialog()
Dim _
cbo As MSForms.ComboBox, _
lPersonCount As Long, _
rng As Range, _
Cell As Range

Set DicName = CreateObject("Scripting.Dictionary")
Set DicDriver = CreateObject("Scripting.Dictionary")
Set DicQF = CreateObject("Scripting.Dictionary")
Set DicFin = CreateObject("Scripting.Dictionary")
Set DicUsed = CreateObject("Scripting.Dictionary")
Set DicTmp = CreateObject("Scripting.Dictionary")

Set rng = Sheet1.Range("Person")
For Each Cell In rng
DicName.Item(Cell.Value) = CStr(Cell.Value)
Next

Set rng = Sheet1.Range("Driver")
For Each Cell In rng
DicDriver.Item(Cell.Value) = CStr(Cell.Value)
Next

Set rng = Sheet1.Range("QFPos")
For Each Cell In rng
DicQF.Item(Cell.Value) = CStr(Cell.Value)
Next

Set rng = Sheet1.Range("FinPos")
For Each Cell In rng
DicFin.Item(Cell.Value) = CStr(Cell.Value)
Next

lPersonCount = 0
For Each cbo In frmDrawResults.fraName.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicName.Keys
Next

For Each cbo In frmDrawResults.fraDriver.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicDriver.Keys
Next

For Each cbo In frmDrawResults.fraQF.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicQF.Keys
Next

For Each cbo In frmDrawResults.fraFin.Controls
lPersonCount = lPersonCount + 1
ReDim Preserve PersonBox(1 To lPersonCount)
Set PersonBox(lPersonCount).PersonGroup = cbo
PersonBox(lPersonCount).PersonGroup.List = DicFin.Keys
Next

frmDrawResults.Show
End Sub

You will note that like Brian, I ditched the RowSource. I also used a Frame control around each group of ComboBoxes. While trying several different ways (mostly with remarkable failure), it struck me that just looping through the controls in the group would be faster than looping through all the controls on the form. If you don't like frames, you could use the Like statement in a larger sense than I did.

Hope this helps,

Mark

Hi GTO,

Thanks for the reply.

I have run your code and it works perfect.
Now, i need to take the time to work my way through and digest your code.

I can't believe something that seems to simple in my mind is so complex in terms of code. All part of the learning though, which is good :)

Thanks again both suggestions chaps.
I'll take a look at both methods and post back any questions and hopefully you will be kind enough to help me progress.

Thanks again
Have a good day.

McC

[Kenneth Hobs]

Youngmcc, quoting all of the code previously posted is generally not advisable.

Using class and dictionary methods as GTO did are efficient methods.

My approach is fairly simple. Basically, one wants to make a Unique set of data and Sort it or not, and then to remove any values that might be listed in the other like named controls. Using a prefix and suffix naming convention for the controls as you did is what I do. The code assumes that your named ranges exist.

See the attachment for the supporting Subs and Functions in Modules. For the Userform code, I show it here with only the first Enter event for one control. In another Module, I wrote 4 Subs to generate the 24 Subs per Sub for the Userform code. I could have done that with VBComponent but this method puts the Subs into the clipboard which makes it easy enough to generate many Subs and then paste in the Immediate window, the Userform or wherever you like.

You will notice that I first set the RowSource for each control with a prefix of "cbo" to nothing. You will probably also want to do something similar if you want to set MatchRequired=True for each combobox unless you really wanted the user to set the value to whatever they like.

Option Explicit
Option Base 0

Private Sub UserForm_Initialize()
Dim ctrl As msforms.Control
For Each ctrl In Me.Controls
If Left(ctrl.Name, 3) = "cbo" Then ctrl.RowSource = Empty
Next ctrl
End Sub

Private Sub cbListSortUnique(cbActive As msforms.ComboBox, cbPattern As String, _
listRange As Range, Optional bSort As Boolean = True)
Dim ctrl As msforms.Control
Dim a() As Variant

a() = UniqueValues(listRange)
If bSort Then orderRoutineOneDim a()
For Each ctrl In Me.Controls
If ctrl.Name Like cbPattern And ctrl.Name <> cbActive.Name Then
If ctrl.Value <> "" Then Call Trim1dArray(a(), ctrl.Value)
End If
Next ctrl

cbActive.ListRows = UBound(a) + 1
cbActive.List() = a()
Erase a()
End Sub

'Routines below generated by copies to clipboard in the Module mClipboardSubs
Private Sub cboName1_Enter()
cbListSortUnique Me.cboName1, "cboName*", Range("Person"), False
End Sub

[GTO]

Using class and dictionary methods as GTO did are efficient methods.

Hi Kenneth,

I wanted to thank you for the comment. As mentioned, Classes and user-defined events are 'out there' for me, so any criticism is most appreciated.

Hope you are starting an enjoyable weekend :-)

Mark