Assuming, for simplicity sake, that

[itmex22]

Assuming, for simplicity sake, that key and item values are the same, is there a way to sort the values in a dictionary object that has been populated ramdonly? For instance, the following code will show the values unsortered:

For each x in objDict
   vOut = vOut & x & "  "
Next
MsgBox vOut

If the values were
c, c
h, h
e, e
a, a
p, p
m, m

Then the output will be:

c h e a p m


It looks like any of the methods associated with the dictionary object will sort the values.

Any thoughts?

Thanks!!

 

[tsuji]

Hello, itmex22.

There is not a build-in sort on array in vbs. Although in js there is array.sort(), but when you think about it, it does help but not enough. The reason is that for an associative arrays of Dictionary object, you want to retain keys and items associativeness. Even for a simple 1-dim array, one may want to know after being sorted to know whereabout of the original index. The solution is just to implement a routine doing just that.

I have a routine, qsort-function implementing the above consideration, a base array (baseAr) being sorted and a control array (ctrAr) keeping track of the sorting or keeping track of its associative array.

The script below illustrative the use of it for Dictionary object. Try it out and see how you like it.

regards - tsuji

'--------------------qsort & dictionary--/tsuji/--------
Option Explicit

Dim oDict
Set oDict = CreateObject("Scripting.Dictionary&quot
With oDict
.Add "a", "Athens"
.Add "b", "Belgrade"
.Add "c", "Cairo"
.Add "z", "Zagrab"
.Add "p", "Paris"
.Add "l", "London"
.Add "s", "San Francesco"
End With

Dim entry
Dim keys, items, i
keys = oDict.Keys
items = oDict.Items

Dim bAsc
bAsc = False
call QSort(items,keys,UBound(items),bAsc)

For i = 0 To oDict.Count-1
WScript.Echo keys(i) & vbTab & items(i)
Next

Set oDict = Nothing
WScript.Quit

'--------------- QSort-----------------------------------/tsuji/--------
Function QSort (baseAr, ctrAr, baseUB, bAsc)

Dim lidx, hidx
If (baseUB > 1) Then
lidx = 0
hidx = baseUB
QSortWork baseAr,ctrAr, lidx, hidx, bAsc
Else
Permute baseAr,ctrAr, 0, 1, bAsc
End If
End Function

Function Permute(ByRef a, ByRef b, ByVal lidx, ByVal hidx, ByRef bAsc)
Dim c
If bAsc And (a(lidx)>a(hidx)) Then
c = a(lidx) : a(lidx) = a(hidx) : a(hidx) = c : c = b(lidx) : b(lidx) = b(hidx) : b(hidx) = c
End If
If (Not bAsc) And (a(lidx)<a(hidx)) Then
c = a(lidx) : a(hidx) = a(lidx) : a(lidx) = c : c = b(hidx) : b(hidx) = b(lidx) : b(lidx) = c
End If
End Function

'-----------QSortWork----------------------------------
Function QSortWork(ByRef baseAr, ByRef ctrAr, ByVal lidx, ByVal hidx, ByRef bAsc)

Dim i, j, ref, a, b
i = hidx
j = lidx
ref = baseAr(((lidx+hidx) / 2))
Do
If bAsc Then
while (baseAr(j) < ref) j = j + 1
wend
while (baseAr(i) > ref) i = i - 1
wend
Else
while (baseAr(j) > ref) j = j + 1
wend
while (baseAr(i) < ref) i = i - 1
wend
End If
If ( i >= j ) Then
If ( i <> j ) Then
a = baseAr(i) : b = ctrAr(i)
baseAr(i) = baseAr(j) : ctrAr(i) = ctrAr(j)
baseAr(j) = a : ctrAr(j) = b
End If
i = i - 1 : j = j + 1
End If
loop while (j <= i)
If (lidx < i) Then
QSortWork baseAr, ctrAr, lidx, i, bAsc
End If
If (j < hidx) Then
QSortWork baseAr, ctrAr, j , hidx, bAsc
End If

End Function
'-----------QSortWork----------------------------------
'--------------- QSort-----------------------------------/tsuji/--------

 

[itmex22]

Thanks tsuji, I'll try it out.

itmex22