Словарь для сортировки ошибок по возрастающему значению ключа

Question

У меня есть пользовательская форма, содержащая выпадающий список, который заполняется из уникальных элементов в столбце рабочей таблицы. Я пытаюсь отсортировать ключи, которые представляют элементы в выпадающем списке в порядке возрастания, используя приведенный ниже код, но я получаю сообщение об «Переменная объекта или переменная блока не установлена» ошибка:

Public Function funcSortKeysByLengthDesc(dctList As Object) As Object 
Dim curKey As Variant 
Dim key As Variant 
Dim itX As Integer 
Dim itY As Integer 
Dim arrTemp() As Variant 
Dim d As Object 

'Only sort if more than one item in the dict 
If dctList.Count > 1 Then 

    'Populate the array 
    ReDim arrTemp(dctList.Count) 
    itX = 0 
    For Each curKey In dctList 
     arrTemp(itX) = curKey 
     itX = itX + 1 
    Next 

    For itX = 0 To (dctList.Count - 2) 
     For itY = (itX + 1) To (dctList.Count - 1) 
      If arrTemp(itX) > arrTemp(itY) Then 
       curKey = arrTemp(itY) 
       arrTemp(itY) = arrTemp(itX) 
       arrTemp(itX) = curKey 
      End If 
     Next 
    Next 

    'Create the new dictionary 
    Set d = CreateObject("Scripting.Dictionary") 

    For itX = 0 To UBound(arrTemp) 
     d.Add arrTemp(itX), dctList(itX) 
    Next 

    Set funcSortKeysByLengthDesc = d 
Else 
    Set funcSortKeysByLengthDesc = dctList 
End If 
End Function 

Answer 1

Я m не совсем уверен, почему вы используете Dicionary для выполнения этой задачи, но я предположил, что это требуется в другом месте вашего проекта, поэтому я попытался согласовать мой существующий код.

Если вы только помещаете отсортированные ячейки в ComboBox, то считывая ячейки в массив, удаляя дубликаты и сортируя этот массив, тогда заполнение ComboBox будет проще. Существует множество примеров того, как выполнять каждую из этих задач на этом сайте, поэтому я не буду воспроизводить их здесь.

Вот код для вас:

Sub RunMe() 
    Dim ws As Worksheet 
    Dim rCell As Range 
    Dim dctItem As String 
    Dim dctArray() As String 
    Dim i As Integer 
    Dim d As Object 
    Dim v As Variant 

    Set ws = ThisWorkbook.Worksheets("Sheet1") 

    'Code to poulate a few "C" cells 
    ws.Cells(3, "C").Resize(10).Value = Application.Transpose(Array("Z", "Y", "X", "W", "W", "E", "D", "C", "B", "A")) 
    UserForm1.Show False 

    'Clear the combobox 
    UserForm1.cbNames.Clear 

    'Create the dictionary 
    Set d = CreateObject("Scripting.Dictionary") 
    For Each rCell In ws.Range("C3", ws.Cells(Rows.Count, "C").End(xlUp)) 
     dctItem = CStr(rCell.Value2) 
     If Not d.Exists(dctItem) Then 
      d.Add dctItem, dctItem 
     End If 
    Next 

    'Convert the dictionary items to an array 
    Debug.Print "PRE-SORT" 
    ReDim dctArray(1 To d.Count) 
    i = 1 
    For Each v In d.Items 
     dctArray(i) = v 
     i = i + 1 
     Debug.Print v 
    Next 

    'Bubble sort the array 
    dctArray = BubbleSort(dctArray) 

    'Populate the dictionary and combobox 
    Debug.Print "POST-SORT" 
    Set d = CreateObject("Scripting.Dictionary") 
    For i = LBound(dctArray) To UBound(dctArray) 
     d.Add dctArray(i), dctArray(i) 
     UserForm1.cbNames.AddItem dctArray(i) 
     Debug.Print dctArray(i) 
    Next 

End Sub 
Private Function BubbleSort(tempArray As Variant) As Variant 
    'Uses Microsoft's version: https://support.microsoft.com/en-us/kb/133135 
    Dim temp As Variant 
    Dim i As Integer 
    Dim noExchanges As Integer 

    ' Loop until no more "exchanges" are made. 
    Do 
     noExchanges = True 

     ' Loop through each element in the array. 
     For i = 1 To UBound(tempArray) - 1 

      ' If the element is greater than the element 
      ' following it, exchange the two elements. 
      If tempArray(i) > tempArray(i + 1) Then 
       noExchanges = False 
       temp = tempArray(i) 
       tempArray(i) = tempArray(i + 1) 
       tempArray(i + 1) = temp 
      End If 
     Next i 
    Loop While Not (noExchanges) 

    BubbleSort = tempArray 

End Function