Function obtainComboBoxListRange(cBox As ComboBox) As Range
If cBox.ListFillRange = "" Then
'do nothing
Else
Set obtainComboBoxListRange = Range(cBox.ListFillRange)
End If
End Function
Function getComboBoxUnique(cBox As ComboBox) As Dictionary
Dim uniqueList As Dictionary
Dim myItem As Variant 'for the list currently in the ComboBox
Dim i As Integer
Set uniqueList = New Dictionary
For i = 0 To cBox.ListCount - 1 'go through the current list and add them to the dictionary (dictionary won't allow duplicates)
If Not uniqueList.Exists(cBox.List(i)) Then 'ignore duplicate "keys"
uniqueList.Add cBox.List(i), i 'item count is the key, and the value is the key as well, for easy retrieval
End If
Next i
Set getComboBoxUnique = uniqueList
End Function
Sub loadMyComboBoxUnique(cBox As ComboBox, Optional Sorted As Variant = False, Optional mLink As Variant = False)
Dim cBoxRangeTest As Range, cBoxRange As Range, cBoxLinkExists As Boolean, sBuildComboBoxName As String
Dim uniqueComboBoxList As Dictionary 'could be number or text
Dim myArray As Variant
'cBox is the ComboBox Active-X control for this operation. mLink is an optional parameter which instructs the app to sustain linkage with the
'listfill range, even though the end result will be a ComboBox with set values. The way this app sustains linkage is to create a defined
'name range built around the name of the ComboBox and containing its initialized list fill range.
'some preliminary setup. Assuming there's a requirement to maintain the link between the data and the combobox, build the range name
'based on the combobox name. Then test to see whether there's already a range that has been assigned to this combobox, setting the flag
'cBoxLinkExists.
sBuildComboBoxName = "_" & cBox.Name & "_Range"
On Error Resume Next
Set cBoxRangeTest = Range(sBuildComboBoxName)
If Err.Number <> 0 Then
cBoxLinkExists = False
Else
cBoxLinkExists = True
End If
Err.Clear
On Error GoTo 0
If Not mLink Then 'maintaining linkage is not desired, so delete references from defined names, if any, and clear the cBoxLinkExists flag
On Error Resume Next 'just in case the name never existed
Application.Names(sBuildComboBoxName).Delete
On Error GoTo 0
cBoxLinkExists = False
End If
'Start the process by getting the list fill range from the ComboBox. If it exists, then use that range. If it does NOT exist, test
'to see whether there was a linkage created via the defined name created for the ComboBox. If THAT linkage exists, then fill the listbox
'as it was originally set up. If it does NOT exist, then fall through and warn the user that a fill range must be set up to initialize the
'Combo Box.
Set cBoxRange = obtainComboBoxListRange(cBox)
'if the ComboBox has no set list fill range to work with, there is no linkage, and the ComboBox actually has data, then the ComboBox has been initialized with values that are unique already, there's nothing to do
If cBoxRange Is Nothing And Not mLink And cBox.ListRows > 0 Then Exit Sub 'nothing to do
If Not cBoxRange Is Nothing Or cBoxLinkExists Then 'either the list fill range of the ComboBox is set, or a prior link exists
'save the range for refresh linkage
If cBoxLinkExists And cBoxRange Is Nothing Then 'there is no list fill range, but the link does exist, so proceed by setting the ComboBox up as it was originally
cBox.ListFillRange = "'" & cBoxRangeTest.Parent.Name & "'!" & cBoxRangeTest.Address
ElseIf mLink Then 'if link is to be maintained, then save the range tied to the combobox reference in the defined names area
Application.Names.Add Name:="'" & ActiveSheet.Name & "'!" & sBuildComboBoxName, RefersTo:="=" & cBox.ListFillRange, Visible:=False 'hide the range name
End If
'regardless of the cases above, we now have a list range from which to work - either from the fill range, or a prior link
'first, create a unique list of elements from the ComboBox "contents", re: its list fill range, in the getComboBoxUnique function
Set uniqueComboBoxList = getComboBoxUnique(cBox) ' ok - got the unique list in the dictionary
'now clear the combobox and load it with unique values
cBox.ListFillRange = "" 'clear the Combobox
'iterate through the dictionary uniqueComboBoxList Keys to get at the elements stored there (re: the unique set of elements in the original
'list fill range
If Not Sorted Then 'load the ComboBox
For i = 0 To uniqueComboBoxList.Count - 1
cBox.AddItem uniqueComboBoxList.Keys(i)
Next i
Else 'sort first
myArray = uniqueComboBoxList.Keys
Call QSort(myArray, LBound(myArray), UBound(myArray))
For i = 0 To uniqueComboBoxList.Count - 1 'now load the ComboBox with sorted array
cBox.AddItem myArray(i)
Next i
End If
Else
MsgBox "Please Go to ComboBox: " & cBox.Name & " and set the Property called ""ListFillRange"" then run this macro"
End If
End Sub
Private Sub ComboBox1_GotFocus()
Call loadMyComboBoxUnique(ComboBox1, True, True) 'The ComboBox is loaded with unique values, sorted, with linkage maintained to the original data range - as data changes, so will the ComboBox maintain its linkage to that data
'Call loadMyComboBoxUnique(ComboBox1, False, False) 'The ComboBox is loaded with unique values, is not sorted (ala Data Validation List), leveraging the ListFillRange for the first time to initiliaze the ComboBox, and remaining static, with no linkage maintained
End Sub
sBuildComboBoxName = "_" & cBox.Name & "_Range"
Application.Names.Add Name:="'" & ActiveSheet.Name & "'!" & sBuildComboBoxName, RefersTo:="=" & cBox.ListFillRange, Visible:=False 'hide the range name
sBuildComboBoxName = "_" & cBox.Name & "_Range"
Set cBoxRangeTest = Range(sBuildComboBoxName)
cBox.ListFillRange = "'" & cBoxRangeTest.Parent.Name & "'!" & cBoxRangeTest.Address
Sub refreshControlsOnSheet(Sh As Object)
'routine enumerates all objects on the worksheet (sh), determines are ComboBoxes with stored settings, then refreshes those settings
'from storage (in the defined names arena). As this navigates through all controls, the presumption is that either listfill range has been set
'on all controls, and this routine is being called ONCE to initialize ALL ComboBoxes, or that some/all of the ComboBoxes have linkage created, so
'the goal is to refresh that linkage. If the listfill range doesn't exist and there's no stored setting, that control will be skipped.
Dim myControl As OLEObject
Dim sBuildControlName As String
Dim sControlSettings As Variant
For Each myControl In ActiveSheet.OLEObjects
If myControl.OLEType = ComboBox_OLEType Then
sBuildComboBoxName = "_" & myControl.Name & "_Range" 'builds a range name based on the control name
On Error Resume Next
Set cBoxRangeTest = Range(sBuildComboBoxName)
If Err.Number <> 0 Then
cBoxLinkExists = False
Else
cBoxLinkExists = True
End If
Err.Clear
On Error GoTo 0
If Not cBoxRangeTest Is Nothing Or cBoxLinkExists Then ' either the control is ready to initialize, or has stored settings already for use
Call loadMyComboBoxUnique(myControl.Object, True, True)
End If
End If
Next myControl
End Sub
Private Sub ComboBox1_GotFocus()
loadMyComboBoxUnique(ComboBox1,TRUE) 'TRUE - to maintain linkage to the ListFillRange, FALSE - just use the initial ListFillRange, get unique values, and load the ComboBox
End Sub
Const ComboBox_OLEType = 2
Function obtainComboBoxListRange(cBox As ComboBox) As Range
If cBox.ListFillRange = "" Then
'do nothing
Else
Set obtainComboBoxListRange = Range(cBox.ListFillRange)
End If
End Function
Function getComboBoxUnique(cBox As ComboBox) As Dictionary
Dim uniqueList As Dictionary
Dim myItem As Variant 'for the list currently in the ComboBox
Dim i As Integer
Set uniqueList = New Dictionary
For i = 0 To cBox.ListCount - 1 'go through the current list and add them to the dictionary (dictionary won't allow duplicates)
If Not uniqueList.Exists(cBox.List(i)) Then 'ignore duplicate "keys"
uniqueList.Add cBox.List(i), i 'item count is the key, and the value is the key as well, for easy retrieval
End If
Next i
Set getComboBoxUnique = uniqueList
End Function
Sub loadMyComboBoxUnique(cBox As ComboBox, Optional Sorted As Variant = False, Optional mLink As Variant = False)
Dim cBoxRangeTest As Range, cBoxRange As Range, cBoxLinkExists As Boolean, sBuildComboBoxName As String
Dim uniqueComboBoxList As Dictionary 'could be number or text
Dim myArray As Variant
'cBox is the ComboBox Active-X control for this operation. mLink is an optional parameter which instructs the app to sustain linkage with the
'listfill range, even though the end result will be a ComboBox with set values. The way this app sustains linkage is to create a defined
'name range built around the name of the ComboBox and containing its initialized list fill range.
'some preliminary setup. Assuming there's a requirement to maintain the link between the data and the combobox, build the range name
'based on the combobox name. Then test to see whether there's already a range that has been assigned to this combobox, setting the flag
'cBoxLinkExists.
sBuildComboBoxName = "_" & cBox.Name & "_Range"
On Error Resume Next
Set cBoxRangeTest = Range(sBuildComboBoxName)
If Err.Number <> 0 Then
cBoxLinkExists = False
Else
cBoxLinkExists = True
End If
Err.Clear
On Error GoTo 0
If Not mLink Then 'maintaining linkage is not desired, so delete references from defined names, if any, and clear the cBoxLinkExists flag
On Error Resume Next 'just in case the name never existed
Application.Names(sBuildComboBoxName).Delete
On Error GoTo 0
cBoxLinkExists = False
End If
'Start the process by getting the list fill range from the ComboBox. If it exists, then use that range. If it does NOT exist, test
'to see whether there was a linkage created via the defined name created for the ComboBox. If THAT linkage exists, then fill the listbox
'as it was originally set up. If it does NOT exist, then fall through and warn the user that a fill range must be set up to initialize the
'Combo Box.
Set cBoxRange = obtainComboBoxListRange(cBox)
'if the ComboBox has no set list fill range to work with, there is no linkage, and the ComboBox actually has data, then the ComboBox has been initialized with values that are unique already, there's nothing to do
If cBoxRange Is Nothing And Not mLink And cBox.ListRows > 0 Then Exit Sub 'nothing to do
If Not cBoxRange Is Nothing Or cBoxLinkExists Then 'either the list fill range of the ComboBox is set, or a prior link exists
'save the range for refresh linkage
If cBoxLinkExists And cBoxRange Is Nothing Then 'there is no list fill range, but the link does exist, so proceed by setting the ComboBox up as it was originally
cBox.ListFillRange = "'" & cBoxRangeTest.Parent.Name & "'!" & cBoxRangeTest.Address
ElseIf mLink Then 'if link is to be maintained, then save the range tied to the combobox reference in the defined names area
Application.Names.Add Name:="'" & ActiveSheet.Name & "'!" & sBuildComboBoxName, RefersTo:="=" & cBox.ListFillRange, Visible:=False 'hide the range name
End If
'regardless of the cases above, we now have a list range from which to work - either from the fill range, or a prior link
'first, create a unique list of elements from the ComboBox "contents", re: its list fill range, in the getComboBoxUnique function
Set uniqueComboBoxList = getComboBoxUnique(cBox) ' ok - got the unique list in the dictionary
'now clear the combobox and load it with unique values
cBox.ListFillRange = "" 'clear the Combobox
'iterate through the dictionary uniqueComboBoxList Keys to get at the elements stored there (re: the unique set of elements in the original
'list fill range
If Not Sorted Then 'load the ComboBox
For i = 0 To uniqueComboBoxList.Count - 1
cBox.AddItem uniqueComboBoxList.Keys(i)
Next i
Else 'sort first
myArray = uniqueComboBoxList.Keys
Call QSort(myArray, LBound(myArray), UBound(myArray))
For i = 0 To uniqueComboBoxList.Count - 1 'now load the ComboBox with sorted array
cBox.AddItem myArray(i)
Next i
End If
Else
MsgBox "Please Go to ComboBox: " & cBox.Name & " and set the Property called ""ListFillRange"" then run this macro"
End If
End Sub
Sub refreshControlsOnSheet(Sh As Object)
'routine enumerates all objects on the worksheet (sh), determines are ComboBoxes with stored settings, then refreshes those settings
'from storage (in the defined names arena). As this navigates through all controls, the presumption is that either listfill range has been set
'on all controls, and this routine is being called ONCE to initialize ALL ComboBoxes, or that some/all of the ComboBoxes have linkage created, so
'the goal is to refresh that linkage. If the listfill range doesn't exist and there's no stored setting, that control will be skipped.
Dim myControl As OLEObject
Dim sBuildControlName As String
Dim sControlSettings As Variant
For Each myControl In ActiveSheet.OLEObjects
If myControl.OLEType = ComboBox_OLEType Then
sBuildComboBoxName = "_" & myControl.Name & "_Range" 'builds a range name based on the control name
On Error Resume Next
Set cBoxRangeTest = Range(sBuildComboBoxName)
If Err.Number <> 0 Then
cBoxLinkExists = False
Else
cBoxLinkExists = True
End If
Err.Clear
On Error GoTo 0
If Not cBoxRangeTest Is Nothing Or cBoxLinkExists Then ' either the control is ready to initialize, or has stored settings already for use
Call loadMyComboBoxUnique(myControl.Object, True, True)
End If
End If
Next myControl
End Sub
Sub initializeControlsOnSheetbyObject()
'simple routine to initialize the three ComboBox controls on the active sheet. The presumption is that perhaps NOT ALL ComboBoxes
'would require this setup, so this is a manual step.
Call loadMyComboBoxUnique(ActiveSheet.OLEObjects("ComboBox1").Object, True, True)
Call loadMyComboBoxUnique(ActiveSheet.OLEObjects("ComboBox2").Object, True, True)
Call loadMyComboBoxUnique(ActiveSheet.OLEObjects("ComboBox3").Object, True, True)
End Sub
Sub initializeAllControlsOnSheet()
Call refreshControlsOnSheet(Sheet1)
End Sub
Sub QSort(sortArray As Variant, ByVal leftIndex As Integer, ByVal rightIndex As Integer)
Dim compValue As Variant
Dim i As Integer
Dim J As Integer
Dim tempVar As Variant
i = leftIndex
J = rightIndex
compValue = sortArray(Int((i + J) / 2))
Do
Do While (sortArray(i) < compValue And i < rightIndex)
i = i + 1
Loop
Do While (compValue < sortArray(J) And J > leftIndex)
J = J - 1
Loop
If i <= J Then
tempVar = sortArray(i)
sortArray(i) = sortArray(J)
sortArray(J) = tempVar
i = i + 1
J = J - 1
End If
Loop While i <= J
If leftIndex < J Then QSort sortArray, leftIndex, J
If i < rightIndex Then QSort sortArray, i, rightIndex
End Sub
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (8)
Commented:
Rory
Commented:
I look forward to reading part II.
Lol, I would assume not too :-)
Thanks Rory, I appreciate the extra info - it's good to understand some of the logic behind/integrated into VBA.
Rob
__________________
Rob Brockett
Kiwi in the UK
Always learning & the best way to learn is to experience...
Commented:
Thanks for taking the time to share!
Author
Commented:Cheers,
Dave
Author
Commented::)
http:\A_6429.html
Dave
View More