Need help adding alphabetical sort to combobox - excel

I have a combobox in an Excel UserForm that I would like to sort alphabetically. I don't have any idea how to add this function, and I would appreciate any help. Here is my VBA:
Private Sub Userform_Initialize()
' Sets range for ComboBox list
Dim rng As Range, r As Range
Set rng = Sheet1.Range("H2:H65536")
For Each r In rng
AddUnique r.value
Next r
End Sub
Sub AddUnique(value As Variant)
Dim i As Integer
Dim inList As Boolean
inList = False
With Me.ComboBox1
For i = 0 To Me.ComboBox1.ListCount - 1
If Me.ComboBox1.List(i) = value Then
inList = True
Exit For
End If
Next i
If Not inList Then
.AddItem value
End If
End With
End Sub

My suggestion is to use a Dictionary to create a collection of only the unique value in your range, then sort it prior to adding the items to your combobox.
If you haven't done so already, add a reference library to your project by going to the Tools menu, then select References. Scroll down the list and find the "Microsoft Scripting Runtime" and check it.
Then it's a simple matter of looping through all the entries -- only adding an item if it doesn't exist already. I lifted a sorting routine from ExcelMastery. Then add the items to your combobox.
Option Explicit
Private Sub Userform_Initialize()
' Sets range for ComboBox list
Dim rng As Range, r As Range
Set rng = Sheet1.Range("H2:H65536")
'--- create a dictionary of the items that will be in
' the combobox
Dim uniqueEntries As Object
Set uniqueEntries = New Scripting.Dictionary
For Each r In rng
'--- all dictionary keys must be a string
Dim keyString As String
If IsNumeric(r) Then
keyString = CStr(r)
Else
keyString = r
End If
If Not uniqueEntries.exists(keyString) Then
uniqueEntries.Add CStr(keyString), r
End If
Next r
Set uniqueEntries = SortDictionaryByKey(uniqueEntries)
CreateComboboxList uniqueEntries
End Sub
Private Sub CreateComboboxList(ByRef dictList As Scripting.Dictionary)
Dim key As Variant
For Each key In dictList.keys
Debug.Print "Adding " & key
'Me.combobox1.AddItem key
Next key
End Sub
'------------------------------------------------------------------
'--- you should put this in a module outside of your userform code
Public Function SortDictionaryByKey(dict As Object, _
Optional sortorder As XlSortOrder = xlAscending) As Object
'--- from ExcelMastery
' https://excelmacromastery.com/vba-dictionary/#Sorting_by_keys
Dim arrList As Object
Set arrList = CreateObject("System.Collections.ArrayList")
' Put keys in an ArrayList
Dim key As Variant, coll As New Collection
For Each key In dict
arrList.Add key
Next key
' Sort the keys
arrList.Sort
' For descending order, reverse
If sortorder = xlDescending Then
arrList.Reverse
End If
' Create new dictionary
Dim dictNew As Object
Set dictNew = CreateObject("Scripting.Dictionary")
' Read through the sorted keys and add to new dictionary
For Each key In arrList
dictNew.Add key, dict(key)
Next key
' Clean up
Set arrList = Nothing
Set dict = Nothing
' Return the new dictionary
Set SortDictionaryByKey = dictNew
End Function

Related

Need a general purpose Excel VBA method for sorting tables

Lately i have been doing a fair amount of work sorting Excel tables and was looking for an Excel VBA method to generalize that task. It needed to be simple and easy to use.
Here is what I came up with:
Public Function SortExcelTable(ExcelTable As ListObject, ParamArray SortRanges() As Variant) As Boolean
The ParamArray handles column numbers, headings or a mixture of the two and can be interspersed with True or False as needed for Ascending or Descending. To make data validation easier, a RangeToDictionary helper method is used. It creates a Case Insensitive dictionary of all of the column headers and is called with ExcelTable.HeaderRowRange. Late binding is used with the Dictionary objects to avoid needing a reference to Microsoft Scripting Runtime.
Public Function RangeToDictionary(Source As Range, _
Optional CaseInsensitive As Boolean = True) As Object ' Scripting.Dictionary
Dim oCell As Range
Dim oDictionary As Object ' Scripting.Dictionary
''Set oDictionary = New Scripting.Dictionary
Set oDictionary = CreateObject("Scripting.Dictionary")
If CaseInsensitive Then
oDictionary.CompareMode = TextCompare
End If
For Each oCell In Source
''Debug.Print oCell.Value
Call oDictionary.Add(oCell.Value, Nothing)
Next
Set RangeToDictionary = oDictionary
Set oCell = Nothing: Set oDictionary = Nothing
End Function
The main function 1.) Validates the incoming ParamArray and converts any column numbers into their corresponding header. This allows validation against the dictionary created by the helper method mentioned above. It then 2.) Spins through the ParamArray again and creates the actual SortFields used in the sort.
A small point of interest is the use of a Dictionary to hold the Range references needed for the SortFields. This technique allows for a varying number of range objects depending upon the ParamArray.
Public Function SortExcelTable(ExcelTable As ListObject, _
ParamArray SortRanges() As Variant) As Boolean
On Error GoTo ErrorHandler
Dim oDictionary As Object ' Scripting.Dictionary
Dim eSortOrder As XlSortOrder
Dim lIndex As Long
Dim sRange As String
Dim vItem As Variant
If UBound(SortRanges) = -1 Then
Call Err.Raise(vbObjectError + 1, "SortExcelTable", "No sort columns(s) specified.")
End If
' Create dictionary of column headers.
Set oDictionary = RangeToDictionary(ExcelTable.HeaderRowRange)
' Validate column values.
For lIndex = LBound(SortRanges) To UBound(SortRanges)
If Not TypeName(SortRanges(lIndex)) = "Boolean" Then
' Convert column numbers to column headers.
If IsNumeric(SortRanges(lIndex)) Then
SortRanges(lIndex) = ExcelTable.HeaderRowRange.Item(SortRanges(lIndex))
End If
' Validate the column header.
If Not oDictionary.Exists(SortRanges(lIndex)) Then
Call Err.Raise(vbObjectError + 2, "SortExcelTable", "Invalid sort column: '" & SortRanges(lIndex) & "'.")
End If
End If
Next
''Set oDictionary = New Scripting.Dictionary
Set oDictionary = CreateObject("Scripting.Dictionary")
With ExcelTable.Sort
.SortFields.Clear
For lIndex = LBound(SortRanges) To UBound(SortRanges)
If TypeName(SortRanges(lIndex)) = "String" Then
' Default to ascending but check to see if next param array value is a boolean.
eSortOrder = xlAscending
If lIndex < UBound(SortRanges) Then
If TypeName(SortRanges(lIndex + 1)) = "Boolean" Then
eSortOrder = IIf(SortRanges(lIndex + 1), xlAscending, xlDescending)
End If
End If
' Use dictionary so any number of sort columns can be handled.
sRange = ExcelTable.Name & "[" & SortRanges(lIndex) & "]"
Call oDictionary.Add(sRange, Range(sRange))
.SortFields.Add Key:=oDictionary.Item(sRange), SortOn:=xlSortOnValues, Order:=eSortOrder
''Debug.Print sRange; " "; IIf(eSortOrder = xlAscending, "xlAscending", "xlDescending")
End If
Next
.Header = xlYes
.Apply
End With
ErrorHandler:
SortExcelTable = (Err.Number = 0)
' Not sure if this step is actually needed.
For Each vItem In oDictionary.Items
If TypeName(vItem) = "Range" Then
Set vItem = Nothing
End If
Next
Set oDictionary = Nothing
On Error GoTo 0
End Function
Here are some sample usages.
Private Sub TestSort()
' Missing paramarray.
Call SortExcelTable(SystemConfiguration.ListObjects.Item(1))
' Invalid column header.
Call SortExcelTable(SystemConfiguration.ListObjects.Item(1), "Hello World!")
' Column numbers.
Call SortExcelTable(SystemConfiguration.ListObjects.Item(1), 2, False, 3)
' Mixed column headers and numbers.
Call SortExcelTable(SystemConfiguration.ListObjects.Item(1), "Include Sheet", False, 3)
' Column headers.
Call SortExcelTable(SystemConfiguration.ListObjects.Item(1), "Include Sheet", False, "Sheet Sequence")
Call SortExcelTable(SystemConfiguration.ListObjects.Item(1), "Orig Row")
End Sub
Enjoy...

Create a string array where the index “value” is a string

Already looked in the forum but was not able to find anything similar.
I would like to create a string array where the index “value” is a string.
For instance:
MyArray(“abc”)=1
MyArray(“def”)=2
MyArray(“ghi”)=3
Is there a way to do this in VBA or can I achieve the same in a different way?
A Dictionary Introduction
A Simple Example
Sub DictIntroduction()
Dim InitText As Variant, InitNumbers As Variant
InitText = Array("abc", "def", "ghi")
InitNumbers = Array(1, 2, 3)
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 0 To UBound(InitText)
dict.Add InitText(i), InitNumbers(i)
Next
Dim Key As Variant
For Each Key In dict.Keys
Debug.Print Key, dict(Key)
Next
Debug.Print dict("abc")
Debug.Print dict("def")
Debug.Print dict("ghi")
End Sub
To find out more about the dictionary visit the following links:
Excel VBA Dictionary - A Complete Guide (Article)
Excel VBA Dictionary (YouTube Playlist)
Sub main()
Set myArray = CreateObject("Scripting.Dictionary")
myArray("abc") = 1
myArray("def") = 2
myArray("ghi") = 3
Debug.Print myArray("abc")
For Each tempKey In myArray
Debug.Print tempKey, myArray(tempKey)
Next
End Sub

Partial String Match (How to match any part of a string while I type in a combobox?)

What I have:
[Form: "Intajform"] - [Combobox: "CustomerName_Combobox"] - [Initialize Event: Load list]
Private Sub UserForm_Initialize()
Dim ws As Worksheet, rCell, srr As Range, Key
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Worksheets("Backend")
Set srr = ws.Range("b2", ws.Cells(Rows.Count, "b").End(xlUp))
For Each rCell In srr
If Not Dic.exists(rCell.Value) Then
Dic.Add (rCell.Value), Nothing
End If
Next rCell
For Each Key In Dic
IntajForm.CustomerName_Combobox.AddItem Key
Next
End Sub
While typing in that combobox to find a match
I CAN FULLY MATCH STRINGS BY FIRST LETTER ONLY
EX: If I type "M" then I find "Microsoft Corporation"
BUT I CAN NOT PARTIALLY MATCH STRINGS
EX: If I type "r" then it is blank " "
Target
I want to partially match the string found in Combobox as long as the letter I type is found in the string.
Use the comboboxe's _Change() event
You have only reduced possibilities to define the .MatchEntry property of a combobox - cf. MS Help - MatchEntry property:
.MatchEntry = fmMatchEntryFirstLetter '
.MatchEntry = fmMatchEntryComplete '
.MatchEntry = fmMatchEntryNone ' no automatic pre-selection at all
To get a narrowed choice list following the currently typed in partial strings you have to use the comboboxe's _Change() event and move the dictionary declaration to the module head to make it available as well for init as for combo changes.
The idea is to present an individualized selection following any entry into the combobox [1] and to force a drop down for better overview [2]:
Option Explicit ' declaration head of code module
Dim Dic As Object ' make dictionary available at module level
Private Sub CustomerName_Combobox_Change()
With Me.CustomerName_Combobox
'[1] narrow data to choose
.List = Filter(Dic.Keys, .Text, True, vbTextCompare) ' <~ corrected/2020-03-15
'[2] expand filter selection (reduced number of valid elements)
.DropDown
End With
End Sub
Private Sub UserForm_Initialize()
Dim ws As Worksheet, rCell As Range, srr As Range, Key
Set Dic = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Worksheets("Backend")
Set srr = ws.Range("b2", ws.Cells(Rows.Count, "b").End(xlUp))
For Each rCell In srr
If Not Dic.exists(rCell.Value) Then
Dic.Add (rCell.Value), Nothing
End If
Next rCell
Me.CustomerName_Combobox.List = Dic.Keys ' << prefix the Me particle to indicate the current instance, not the Userform name itself :-)
End Sub
Further hint: it's possible to assign all dictionary keys to the combobox .List property at once instead of looping (see _Initialize()). And avoid constructions like IntajForm.CustomerName_Combobox.AddItem Key, just reference the control's name or prefix it by Me to indicate the current instance of the UserForm (class) giving you the public members of that object.
FYI - For further insight of the Me qualifier and a Userform itself you might profit from reading
Understanding Me - no flowers, no bees as well as
UserForm1.Show?

Private Function skipping For Loop

I am trying to now learn how Dictionaries work within VBA, so I created a simple Class Module, A Function, and then two subs, but for reasons beyond me the For loop is completely skipped within the function. Below is the Code for all of the items mentioned above. I do have the Microsoft Scripting Runtime checked in Tools > References. Im not really familiar with how Late and Early Binding are utilized, so I'm wondering if that's one of the issues.
Currently the Set rg = LoanData.Range("AH2") is in a table, I have tried the data in that range as both a table and also as just a range, but the For Loop in the function is skipped if the data is in a Table or not.
Class Module called clsCounty
Public CountyID As Long
Public County As String
Function called ReadCounty
Private Function ReadCounty() As Dictionary
Dim dict As New Dictionary
Dim rg As Range
Set rg = LoanData.Range("AH2")
Dim oCounty As clsCounty, i As Long
For i = 2 To rg.Rows.Count
Set oCounty = New clsCounty
oCounty.CountyID = rg.Cells(i, 1).Value
oCounty.County = rg.Cells(i, 2).Value
dict.Add oCounty.CountyID, oCounty
Next i
Set ReadCounty = dict
End Function
The two subs to write to the immediate window
Private Sub WriteToImmediate(dict As Dictionary)
Dim key As Variant, oCounty As clsCounty
For Each key In dict.Keys
Set oCounty = dict(key)
With oCounty
Debug.Print .CountyID, .County
End With
Next key
End Sub
Sub Main()
Dim dict As Dictionary
Set dict = ReadCounty
WriteToImmediate dict
End Sub
You've declared your range as Set rg = LoanData.Range("AH2") and then use For i = 2 To rg.Rows.Count in your loop. the rg.Rows.Count will be 1 as there is only 1 cell in your range. This is before the starting value for your For loop (2) so it won't do anything.
i.e. For i = 2 to 1
Declare your rg variable with the full range. I'm going to guess something like
With LoanData
Set rg = .Range(.Cells(1,"AH"), .Cells(.Cells(.Rows.Count, "AH").End(xlUp).Row, "AH"))
End With
The problem is indeed in the usage of Set rg = LoanData.Range("AH2"), as mentioned in the other answer.
However, to be a bit more elegant, you may consider using LastRow, function, which takes as arguments columnToCheck and wsName:
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
In the code, it would look like this:
Private Function ReadCounty() As Dictionary
Dim dict As New Dictionary
Dim oCounty As clsCounty, i As Long
'For i = 2 To LastRow("LoanData", 34)
For i = 2 To LastRow(LoanData.Name, Range("AH1").Column)
Set oCounty = New clsCounty
oCounty.CountyID = LoanData.Cells(i, "AH").Value
oCounty.County = LoanData.Cells(i, "AI").Value
dict.Add oCounty.CountyID, oCounty
Next i
Set ReadCounty = dict
End Function

VBA-excel dictionary

Im copying cells from one sheet to another, finding and matching column header names and pasting to the correct cell. These column header names differ slightly per sheet, altough they contain the same data. My working code has a lot of repetition:
' sub that finds head in a specified worksheet and sets rngCol variable
Sub rngByHead(Sheet As Worksheet, head As String)
' sub for copying data
With Source1
' find and set producer, note name difference)
Call rngByHead(Source1, "bedrijfsnaam")
Dim producent As String
producent = .Cells(docSource1.Row, rngCol).Value
' find and set Fase
Call rngByHead(Source1, "Fase")
Dim fase As String
fase = .Cells(docSource1.Row, rngCol).Value
' find and set Status
Call rngByHead(Source1, "Status")
Dim status As String
status = .Cells(docSource1.Row, rngCol).Value
' find and set versionnumber, note name difference
Call rngByHead(Source1, "Wijziging")
Dim versienummer As String
versienummer = .Cells(docSource1.Row, rngCol).Value
End With
With Target
' find and write all variables to uploadlijst
Call rngByHead(Target, "bestandsnaam")
.Cells(cell.Row, rngCol).Value = bestand
Call rngByHead(Target, "producent")
.Cells(cell.Row, rngCol).Value = producent
Call rngByHead(Target, "fase")
.Cells(cell.Row, rngCol).Value = LCase(fase)
Call rngByHead(Target, "status")
.Cells(cell.Row, rngCol).Value = LCase(status)
Call rngByHead(Target, "versienummer")
.Cells(cell.Row, rngCol).Value = versienummer
End With
I was trying a more cleaner option with a dictionary for matching the different header names in target and data sheets. I also created a secong dictionary to store those values under the specific keys. I keep getting errors on this code, both 424 object missing as ByRef argument type mismatch.
' Create dict
Dim dict As Scripting.Dictionary
' Create dictValues
Dim dictValues As Scripting.Dictionary
Dim key As Object
' Add keys to dict
dict("producent") = "Bedrijfsnaam"
dict("fase") = "Fase"
dict("status") = "Status"
dict("versienummer") = "Wijziging"
dict("documentdatum") = "Datum"
dict("omschrijving1") = "Omschrijving 1"
dict("omschrijving2") = "Omschrijving 2"
dict("omschrijving3") = "Omschrijving 3"
dict("discipline") = "Discipline"
dict("bouwdeel") = "Bouwdeel"
dict("labels") = "Labels"
' store values of sheet Source 1
With Source1
' create second dictValues to store values for each key
Set dictValues = New Scripting.Dictionary
' loop through keys in dict, this line gives error 424
For Each key In dict.Keys
' use dict to pass right value to rngByHead sub
Call rngByHead(Target, dict(key))
' store value of cell to dictValues under same key
dictValues(key) = .Cells(cell.Row, rngCol).Value
Next key
End With
' set values to sheet Target
With Target
' loop through keys in dict
For Each key In dict.Keys
' use dict to pass value of key item to rngByHead sub
Call rngByHead(Target, key)
' set value of cell to dictValues
.Cells(cell.Row, rngCol).Value = dictValues(key)
Next key
End With
What am I doing wrong? I'm new to vba dictionary and can't figure this one out. Thanks for your help!
Try like this:
Dim dict As New Scripting.Dictionary
Dim dictValues As New Scripting.Dictionary
The keyword New initializes an object from type Scripting.Dicitionary. Without it, no new object is initialized, just an object of type Scripting.Dictionary is declared. This is called early binding in VBA. See a bit here - What is the difference between Early and Late Binding?
I fixed it! Posting the code here on Stackoverflow for future reference. It turned out to be very simple, my dictionary was working fine. The key or k variable was set as Variant or Object, so it didn't pass it's value correctly as String to the rngByHead sub. Converting the k to str as String did the trick.
'sub that finds head in a specified worksheet and sets rngCol variable
Sub rngByHead(Sheet As Worksheet, head As String)
'setting up dictionary
Dim dict As New Scripting.Dictionary
Dim dictValues As New Scripting.Dictionary
Dim k As Variant
Dim str As String
'create dictionary
Set dictValues = New Scripting.Dictionary
Set dict = New Scripting.Dictionary
'add keys to dict
dict("producent") = "Bedrijfsnaam"
dict("fase") = "Fase"
dict("status") = "Status"
dict("versienummer") = "Wijziging"
dict("documentdatum") = "Datum"
dict("omschrijving1") = "Omschrijving"
dict("omschrijving2") = "Omschrijving 2"
dict("omschrijving3") = "Omschrijving 3"
dict("discipline") = "Discipline"
dict("bouwdeel") = "Bouwdeel"
dict("labels") = "Labels"
'store values of sheet Source 1
With Source1
'find and set variables using dictionary
'creating array of keys
keys = dict.keys
For Each k In keys
Call rngByHead(Source1, dict(k))
dictValues(k) = .Cells(docSource1.Row, rngCol).Value
Next
End With
With Target
'find and write variables using dictionary
For Each k In keys
'converting k as Variant to str as String
str = k
Call rngByHead(Target, str)
.Cells(cell.Row, rngCol).Value = dictValues(k)
Next
End With
Another note: you have to enable Microsoft Scripting Runtime in microsoft visual basic code editor under Tools > References.
Provided a user has enabled the option Trust Access to the VBA Project object model in File -> Options -> Trust Center -> Trust Center Setttings -> Macro Settings. You can run this code and enable the Microsoft Scripting Runtime reference:
Sub Test()
Dim Ref As Object, CheckRefEnabled%
CheckRefEnabled = 0
With ThisWorkbook
For Each Ref In .VBProject.References
If Ref.Name = "Scripting" Then
CheckRefEnabled = 1
Exit For
End If
Next Ref
If CheckRefEnabled = 0 Then
.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End If
End With
End Sub

Resources