Sort a scripting dictionary

Here's my dilemna.
I'd like to be able to sort a scripting dictionary.
I was successful at one point but the items associated with the keys were
being displayed correctly.

For example, the code below searches the current drawing for any blocks
called LITE*.
It then tallies up each one based on an attribute.
So if I have 5 lite blocks with A and 7 with B and 3 with C, I'd like to
print out to the immediate window A--5, B--7 and C--3.
However, what I'm currently getting is B--7, A--5 and C--3.
How can I get these sorted correctly??

Code:

Public objKeys As Variant
Public objItems As Variant


Public Sub MainTable()
Dim varAtts() As AcadAttributeReference
Dim objBlock As AcadBlockReference
Dim ssSet As AcadSelectionSet
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
Dim obj As AcadEntity
Dim i As Integer

Set ssSet = vbdPowerSet("BlockCount")

FilterType(0) = 0
FilterData(0) = "Insert"
FilterType(1) = 2
FilterData(1) = "LITE*"

ssSet.Select acSelectionSetAll, , , FilterType, FilterData
Dim objDict As Dictionary
Set objDict = New Dictionary
Dim x As Integer
x = 1
If ssSet.Count = 0 Then
MsgBox "No light fixture blocks were found in this drawing!",
vbInformation + vbOKOnly, "Quick Report"
Exit Sub
Else
For Each obj In ssSet
Set objBlock = obj
If obj.HasAttributes Then
varAtts = obj.GetAttributes
For i = LBound(varAtts) To UBound(varAtts)
If UCase$(varAtts(i).TagString) = "ID" Then
If objDict.Exists(varAtts(i).TextString) = False
Then
objDict.Add varAtts(i).TextString, 1
Else
objDict.Item(varAtts(i).TextString) =
objDict.Item(varAtts(i).TextString) + 1
End If
End If
On Error GoTo 0
Next i
End If
Next obj
i = 0
objKeys = objDict.Keys
objItems = objDict.Items

For x = 0 To UBound(objKeys)
Debug.Print objKeys(x) & vbTab & objItems(x)
Next
CreateTable
End If
End Sub

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
Dim objSelSet As AcadSelectionSet
Dim objSelCol As AcadSelectionSets

Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = strName Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
Set vbdPowerSet = objSelSet
End Function

Thanks in advance!

 

Change your Debug loop to the following:

Code:

objKeys = objDict.Keys
BubbleSort objKeys
For x = 0 To UBound(objKeys)
Debug.Print objKeys(x) & vbTab & objDict(objKeys(x))
Next

and include the following routine from the VB2TheMax Team

Code:

Sub BubbleSort(arr As Variant, Optional descending As Boolean, Optional numEls As Variant)
' Bubble Sort an array of any type
' Author: The VB2TheMax Team
' BubbleSort is especially convenient with small arrays (1,000
' items or fewer) or with arrays that are already almost sorted
'
' NUMELS is the index of the last item to be sorted, and is
' useful if the array is only partially filled.
'
' Works with any kind of array, except UDTs and fixed-length
' strings, and including objects if your are sorting on their
' default property. String are sorted in case-sensitive mode.
'
' You can write faster procedures if you modify the first two lines
' to account for a specific data type, eg.
' Sub BubbleSortS(arr() As Single, Optional descending As Boolean, Optional numEls As Variant)
'   Dim value As Single

Dim Value As Variant
Dim Index As Long
Dim firstItem As Long
Dim indexLimit As Long, lastSwap As Long

' account for optional arguments
If IsMissing(numEls) Then numEls = UBound(arr)
firstItem = LBound(arr)
lastSwap = numEls

Do
indexLimit = lastSwap - 1
lastSwap = 0
For Index = firstItem To indexLimit
Value = arr(Index)
If (Value > arr(Index + 1)) Xor descending Then
' if the items are not in order, swap them
arr(Index) = arr(Index + 1)
arr(Index + 1) = Value
lastSwap = Index
End If
Next
Loop While lastSwap
End Sub

Regards

Wayne Ivory
IT Analyst Programmer
Wespine Industries Pty Ltd

 

Thanks Wayne!
Much appreciated!