View Single Post
 
Old 12-27-2004, 03:02 AM
Flyguy's Avatar
Flyguy Flyguy is offline
Lost Soul

Super Moderator
* Guru *
 
Join Date: May 2001
Location: Vorlon
Posts: 19,164
Default MultiColumn sort: the Next Generation

Quote:
Originally Posted by Flyguy
The MSFlexgrid does have some capabilities for sorting.
It works great if you want to sort 1 column.
If you want to sort multiple columns the flexgrid always sorts them from left to right and all in the same order (ascending/descending).
In the previous sort sample I used a stable sorting mechanisme, which means you sort the data in multiple steps while trying to preserve the orginal data order for other columns.
Somehow it isn't that stable at all and there are some problems when mixing ascending and descending sorting.

In the next sample I used a different technique which is not stable, but does the multi column sorting in a single step.

For this sample you need a form with:
1. MSFlexGrid control named MSFlexGrid1
1. Command button named Command1

Code:
'--------------------------------------------------------------------------------------- ' Module : Form1 ' DateTime : 27-12-2004 ' Author : Flyguy ' Purpose : Demo for sorting multiple columns, data showed in a MSFlexGrid '--------------------------------------------------------------------------------------- Option Explicit Private Sub Form_Load() Dim lRow As Long, lCol As Long ' Just fill the grid with some random data With MSFlexGrid1 .Cols = 6 .Rows = 10 For lRow = .FixedRows To .Rows - 1 For lCol = .FixedCols To .Cols - 1 .TextMatrix(lRow, lCol) = Int(Rnd * 4) Next lCol Next lRow End With End Sub Private Sub Command1_Click() Dim aData() As String Dim lRow As Long, lCol As Long Dim cColumn As Collection, cOrder As Collection ' Put the grid data in a string array With MSFlexGrid1 ReDim aData(.Rows - .FixedRows - 1, .Cols - .FixedCols - 1) For lRow = .FixedRows To .Rows - 1 For lCol = .FixedCols To .Cols - 1 aData(lRow - .FixedRows, lCol - .FixedCols) = .TextMatrix(lRow, lCol) Next lCol Next lRow End With ' Set the sorting parameters Set cColumn = New Collection Set cOrder = New Collection cColumn.Add 0 cOrder.Add 1 ' sort Ascending cColumn.Add 1 cOrder.Add -1 ' sort Descending cColumn.Add 2 cOrder.Add 1 ' sort Ascending ' Sort the grid ShellSortMultiColumn aData, cColumn, cOrder ' Put the data back in the grid With MSFlexGrid1 For lRow = .FixedRows To .Rows - 1 For lCol = .FixedCols To .Cols - 1 .TextMatrix(lRow, lCol) = aData(lRow - .FixedRows, lCol - .FixedCols) Next lCol Next lRow End With End Sub
In a module:
Code:
'--------------------------------------------------------------------------------------- ' Module : modShellSort ' DateTime : 27-12-2004 ' Author : Flyguy '--------------------------------------------------------------------------------------- Option Explicit '--------------------------------------------------------------------------------------- ' Procedure : ShellSortMultiColumn ' DateTime : 27-12-2004 ' Author : Flyguy ' Purpose : Sort a 2D string array on multiple columns '--------------------------------------------------------------------------------------- Public Sub ShellSortMultiColumn(sArray() As String, cColumns As Collection, _ cOrder As Collection) Dim lLoop1 As Long, lHValue As Long Dim lUBound As Long, lLBound As Long Dim lUBound2 As Long, lLBound2 As Long Dim lNofColumns As Long Dim aColumns() As Long, aOrder() As Long Dim bSorted As Boolean If cColumns Is Nothing Then Exit Sub If cOrder Is Nothing Then Exit Sub If cColumns.Count <> cOrder.Count Then Exit Sub lNofColumns = cColumns.Count ReDim aColumns(lNofColumns) ReDim aOrder(lNofColumns) For lLoop1 = 1 To lNofColumns aColumns(lLoop1) = cColumns(lLoop1) aOrder(lLoop1) = cOrder(lLoop1) Next lLoop1 lUBound = UBound(sArray) lLBound = LBound(sArray) lUBound2 = UBound(sArray, 2) lLBound2 = LBound(sArray, 2) lHValue = (lUBound - lLBound) \ 2 Do While lHValue > lLBound Do bSorted = True For lLoop1 = lLBound To lUBound - lHValue If CompareValues(sArray, lLoop1, lLoop1 + lHValue, lNofColumns, _ aColumns, aOrder) Then SwapLines sArray, lLoop1, lLoop1 + lHValue, lLBound2, lUBound2 bSorted = False End If Next lLoop1 Loop Until bSorted lHValue = lHValue \ 2 Loop End Sub '--------------------------------------------------------------------------------------- ' Procedure : SwapLines ' DateTime : 27-12-2004 ' Author : Flyguy ' Purpose : Swap a row of data in a 2D array '--------------------------------------------------------------------------------------- Private Sub SwapLines(ByRef sArray() As String, lIndex1 As Long, _ lIndex2 As Long, lLBound As Long, lUBound As Long) Dim i As Long, sTemp As String For i = lLBound To lUBound sTemp = sArray(lIndex1, i) sArray(lIndex1, i) = sArray(lIndex2, i) sArray(lIndex2, i) = sTemp Next i End Sub '--------------------------------------------------------------------------------------- ' Procedure : CompareValues ' DateTime : 27-12-2004 ' Author : Flyguy ' Purpose : Compare column values for multicolumn sorting '--------------------------------------------------------------------------------------- Private Function CompareValues(ByRef sArray() As String, lIndex1 As Long, _ lIndex2 As Long, lNofColumns As Long, aColumns() As Long, aOrder() As Long) Dim i As Long Dim lCol As Long Dim sValue1 As String, sValue2 As String For i = 1 To lNofColumns lCol = aColumns(i) If aOrder(i) = 1 Then sValue1 = sArray(lIndex1, lCol) sValue2 = sArray(lIndex2, lCol) Else sValue1 = sArray(lIndex2, lCol) sValue2 = sArray(lIndex1, lCol) End If If sValue1 < sValue2 Then Exit For ElseIf sValue1 > sValue2 Then CompareValues = True Exit For End If Next i End Function
Reply With Quote