Sort values in a listbox

[Darren Hill]

Is it possible to sort the values in a listbox by, say, the third
column?
I can do this at present by writing the contents to a worksheet, sorting
it, then refilling the listbox, but there must be a better way.

TIA
--
Darren
"The people can always be brought to the bidding of the leaders. That is
easy. All you have to do is tell them they are being attacked and
denounce the peacemakers for lack of patriotism and exposing the country
to danger. It works the same in any country."
Herman Goering

[Dave Peterson]

Visit John Walkenbach's site:

http://j-walk.com/ss/excel/tips/tip47.htm

--

Dave Peterson
ec3...@msn.com

[Tom Ogilvy]

While John's article is excellent and I use it all the time, I am not sure
it is easily converted to sort a two-D array on the third column - well, it
wouldn't be hard, but it also wouldn't be very efficient. Here is a routine
you might want to try:

As to sorting on a specific column, I modified a quicksort routine
originally posted by Jim Rech to do that:

(the example routine at the bottom which calls the quicksort routine
specifies column 5 as the sort column)

since the col argument is used like this: SortArray(Array, col to sort,
LowerBound, Upperbound, bAscending)
then the 5 would be the sixth column in a zero based array and the 5th in a
1's based array.

Error checking is left as an exercise for the user.

Sub QuickSort(SortArray, col, L, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified by T Ogilvy to sort on first column of a two dimensional array
'Modified by T Ogilvy to handle a a second dimension greater than 1 (or
zero)
'Modified by T Ogilvy to do Ascending or Descending
Dim i, j, X, Y, mm

i = L
j = R
X = SortArray((L + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub

Sub aaTesterSort()
Dim bAscending As Boolean
Set rng = Range("I7").CurrentRegion
vArr = rng.Value
bAscending = False
QuickSort vArr, 5, LBound(vArr, 1), UBound(vArr, 1), bAscending
Range("I26").Resize(UBound(vArr, 1), UBound(vArr, 2)).Value = vArr
End Sub

Regards,
Tom Ogilvy

Dave Peterson <ec3...@msn.com> wrote in message
news:3DF55D7C...@msn.com...

[Darren Hill]

Thanks, that looks like it'll do the trick, but I'm confused about
something.

The code is below, and my query is within these: #########:

Sub RemoveDuplicates()
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item

' The items are in A1:A105
Set AllCells = Range("A1:A105")

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
###################
Since the duplicates aren't added, what does
this part of the code actually do?
###################
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell

' Resume normal error handling
On Error GoTo 0

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

' Add the sorted, non-duplicated items to a ListBox
For Each Item In NoDupes
UserForm1.ListBox1.AddItem Item
Next Item

' Show the UserForm
UserForm1.Show
End Sub

--
Darren

Dave Peterson <ec3...@msn.com> wrote in message
news:3DF55D7C...@msn.com...

> Visit John Walkenbach's site:
>
> http://j-walk.com/ss/excel/tips/tip47.htm
>
>
>
> Darren Hill wrote:
> >
> > Is it possible to sort the values in a listbox by, say, the third
> > column?
> > I can do this at present by writing the contents to a worksheet,
sorting
> > it, then refilling the listbox, but there must be a better way.
> >
> > TIA
> > --
> > Darren

> --
>
> Dave Peterson
> ec3...@msn.com

[Darren Hill]

This looks useful, but as it happens I need to sort on two columns (I
didn't realise this till I saw the code in practice).

Since I'm sorting data in a listbox rather than on the sheet, I've
changed the launching macro as follows

===========
Sub aaTesterSort()
Dim vArr
Dim bAscending As Boolean

vArr = frmManager.LstSetCurrent.List()

bAscending = True
QuickSort vArr, 1, LBound(vArr, 1), UBound(vArr, 1), bAscending

frmManager.LstSetCurrent.List() = vArr
End Sub
===========

How could I sort on column 1 as primary, then column 0?

Thanks again.
--
Darren

Tom Ogilvy <twog...@msn.com> wrote in message
news:OaiO25$nCHA.2464@TK2MSFTNGP11...

[Tom Ogilvy]

I have never seen an algorithm posted that can sort on more than 1 key or
found one using google or found one in any book.

I suspect you would have to sort on the first key, then partition your data
by each matching set of first keys and sort those subsets as individual
items and reassemble, or

concatenate your 1st and second keys as fixed width strings in another
"Dummy" column, then sort on that column, then remove that column.

Regards,
Tom Ogilvy

Darren Hill <star...@btinternet.com> wrote in message
news:at3rj0$h93$1...@venus.btinternet.com...

[Darren Hill]

Using a worksheet range to sort them is looking very attractive right
now! :)

You said:
> I suspect you would have to sort on the first key, then partition your
data
> by each matching set of first keys and sort those subsets as
individual
> items and reassemble, or

This is the approach I went for. I produced the following code, but a
problem occurs when it calls the Quicksort you provided. I've entered
comments highlighted with ##### symbols.

Sub aaTesterSort()
Dim vArr As Variant, vArrPrime(), vArrSecond()
Dim bAscending As Boolean
Dim PriCount As Integer, SecCount As Integer, iCount As Integer,
ColCount As Integer
vArr = frmManager.LstSetCurrent.List()

bAscending = False

QuickSort vArr, 1, LBound(vArr, 1), UBound(vArr, 1), bAscending

' count how many items in each list
'#### Note that, as it happens, there are only two possible values
'#### in the second column, here assumed to be "Primary"
'#### and secondary.

PriCount = 0: SecCount = 0
For iCount = 0 To frmManager.LstSetCurrent.ListCount - 1
If vArr(iCount, 1) = "Primary" Then
PriCount = PriCount + 1
Else
SecCount = SecCount + 1
End If
Next iCount

ReDim vArrPrime(PriCount - 1, 4)
ReDim vArrSecond(SecCount - 1, 4)

PriCount = 0: SecCount = 0
For iCount = 0 To frmManager.LstSetCurrent.ListCount - 1
'#### I've just realised that the following loop could have been
'#### done a lot slicker, since column 2 has already been sorted
'#### oh well, next rewrite :)
'#### Is there a way to copy an entire row from an array at once?
'#### (rather than the For ColCount = 0 to 4 method)

If vArr(iCount, 1) = "Primary" Then
For ColCount = 0 To 4
vArrPrime(PriCount, ColCount) = vArr(iCount, ColCount)
Next ColCount
PriCount = PriCount + 1
Else
For ColCount = 0 To 4
vArrSecond(SecCount, ColCount) = vArr(iCount, ColCount)
Next ColCount
SecCount = SecCount + 1
End If
Next iCount

bAscending = True
QuickSort vArrPrime, 0, LBound(vArr, 1), UBound(vArr, 1), bAscending

'#### Here's where the problem lies: once the above line
'#### calls the QuickSort function
'#### an error occurs on the line:
'#### X = SortArray((L + R) / 2, col)
'#### and I'm stumped as I don't really understand what's going on
'#### there anyway...

QuickSort vArrSecond, 0, LBound(vArr, 1), UBound(vArr, 1), bAscending

iCount = 0
For PriCount = LBound(vArrPrime, 1) To UBound(vArrPrime, 1)
For ColCount = 0 To 4
vArr(PriCount) = vArrPrime(PriCount)
iCount = iCount + 1
Next ColCount
Next PriCount
For SecCount = LBound(vArrPrime, 1) To UBound(vArrPrime, 1)
For ColCount = 0 To 4
vArr(SecCount + iCount) = vArrSecond(SecCount)
Next ColCount
Next SecCount

frmManager.LstSetCurrent.List() = vArr
End Sub

--
Darren

Tom Ogilvy <twog...@msn.com> wrote in message

news:OAZbx5AoCHA.1872@TK2MSFTNGP09...

[Darren Hill]

Oops - I realised what the mistake was in the earlier code (my sloppy
cut and paste techniques). It now appears to be working. Thanks, Tom,
for the sort function that makes it possible.

In case anyone's interested in the working product, it's below the
following question.

Is there a way to replace the following:

For ColCount = 0 To 4
vArrPrime(PriCount, ColCount) = vArr(iCount, ColCount)
Next ColCount

with something like
vArrPrime(PriCount).Row = vArr(iCount).Row
???

Sub aaTesterSort()
Dim vArr As Variant, vArrPrime(), vArrSecond()
Dim bAscending As Boolean
Dim PriCount As Integer, SecCount As Integer, iCount As Integer,
ColCount As Integer
vArr = frmManager.LstSetCurrent.List()

bAscending = False
QuickSort vArr, 1, LBound(vArr, 1), UBound(vArr, 1), bAscending

' count how many items in each list

PriCount = 0: SecCount = 0
For iCount = 0 To frmManager.LstSetCurrent.ListCount - 1
If vArr(iCount, 1) = "Primary" Then
PriCount = PriCount + 1
Else
SecCount = SecCount + 1
End If
Next iCount

ReDim vArrPrime(PriCount - 1, 4)
ReDim vArrSecond(SecCount - 1, 4)

PriCount = 0: SecCount = 0
For iCount = 0 To frmManager.LstSetCurrent.ListCount - 1

If vArr(iCount, 1) = "Primary" Then

For ColCount = 0 To 4
vArrPrime(PriCount, ColCount) = vArr(iCount, ColCount)
Next ColCount
PriCount = PriCount + 1
Else
For ColCount = 0 To 4
vArrSecond(SecCount, ColCount) = vArr(iCount, ColCount)
Next ColCount
SecCount = SecCount + 1
End If
Next iCount

bAscending = True
QuickSort vArrSecond, 0, LBound(vArrSecond, 1), UBound(vArrSecond, 1),
bAscending
QuickSort vArrPrime, 0, LBound(vArrPrime, 1), UBound(vArrPrime, 1),
bAscending

iCount = 0
For PriCount = LBound(vArrPrime, 1) To UBound(vArrPrime, 1)
For ColCount = 0 To 4

vArr(PriCount, ColCount) = vArrPrime(PriCount, ColCount)
Next ColCount

iCount = iCount + 1

Next PriCount
For SecCount = LBound(vArrSecond, 1) To UBound(vArrSecond, 1)

For ColCount = 0 To 4

vArr(SecCount + iCount, ColCount) = vArrSecond(SecCount,
ColCount)
Next ColCount
Next SecCount

frmManager.LstSetCurrent.List() = vArr
End Sub
--
Darren

Darren Hill <star...@btinternet.com> wrote in message
news:at42lb$tb$1...@knossos.btinternet.com...

[Dave Peterson]

It was more basic than that. I missed that part of the question (again, sigh!).

--

Dave Peterson
ec3...@msn.com