VB and VBA Users Source Code: Sorting the rows in a 2D array
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Sorting the rows in a 2D array
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Thursday, November 08, 2001
Hits:
933
Category:
Visual Basic General
Article:
The following code sorts the items in a 2d array by a specified row. 'Purpose : Sorts a 2d array by a specified row number. 'Inputs : avValues A 2D array of values to sort ' lByRow The Row to perform the sort on ' bSortDescending If True Sorts the values in desending order 'Outputs : Values are returned ByRef through the input parameter avValues 'Author : Andrew Baker 'Date : 28/10/2000 08:17 'Notes : When viewed in the immediate window the sorting is applied thus: ' + avValues(Row1,Col1) * Sorted by this row ' avValues(Row1,Col2) * Sorted by this row ' avValues(Row1,Col3) * Sorted by this row ' + avValues(Row2,Col1) ' avValues(Row2,Col2) ' avValues(Row2,Col3) ' ' If lByRow = 1 then the sort is applied as indicated by the * Function Array2dSortRows(ByRef avValues As Variant, ByVal lByRow As Long, Optional ByVal bSortDescending As Boolean = False) As Long Dim lNumRows As Long, lThisCol As Long, lNumCols As Long, lStartCol As Long, lStartRow As Long Dim lPointer As Long, lThisRow As Long Dim alOrder() As Long, avOutput() As Variant Dim lThisCol2 As Long, lSortedCount As Long Dim lThisCol3 As Long Dim lPtr As Long On Error GoTo ErrFailed lStartCol = LBound(avValues, 2) If Err.Number Then Debug.Print "Array2dSortRows Error: NOT A 2D ARRAY!" On Error GoTo 0 Exit Function End If lStartRow = LBound(avValues) lNumCols = UBound(avValues, 2) lNumRows = UBound(avValues) ReDim alOrder(lStartCol To lNumCols) For lThisCol = lStartCol To lNumCols alOrder(lThisCol) = lThisCol Next If bSortDescending Then 'Sort items in descending order Do 'Sort pointers to items in array lSortedCount = 0 For lThisCol = lNumCols To lStartCol + 1 Step -1 If avValues(lByRow, alOrder(lThisCol)) > avValues(lByRow, alOrder(lThisCol - 1)) Then 'Find the new position for this item For lThisCol2 = lThisCol - 1 To lStartCol + 1 Step -1 If avValues(lByRow, alOrder(lThisCol)) < avValues(lByRow, alOrder(lThisCol2 - 1)) Then 'Found the new position for the pointer Exit For End If Next 'Move all the pointer positions up a position lPtr = alOrder(lThisCol) For lThisCol3 = lThisCol To lThisCol2 + 1 Step -1 alOrder(lThisCol3) = alOrder(lThisCol3 - 1) Next 'Copy pointer into new position alOrder(lThisCol2) = lPtr lSortedCount = lSortedCount + 1 'Go back to the previous row lThisCol = lThisCol + 1 End If Next Loop While lSortedCount Else 'Sort items in ascending order Do 'Sort pointers to items in array lSortedCount = 0 For lThisCol = lStartCol To lNumCols - 1 If avValues(lByRow, alOrder(lThisCol)) > avValues(lByRow, alOrder(lThisCol + 1)) Then 'Find the new position for this item For lThisCol2 = lThisCol + 1 To lNumCols - 1 If avValues(lByRow, alOrder(lThisCol)) < avValues(lByRow, alOrder(lThisCol2 + 1)) Then 'Found the new position for the pointer Exit For End If Next 'Move all the pointer positions up a position lPtr = alOrder(lThisCol) For lThisCol3 = lThisCol To lThisCol2 - 1 alOrder(lThisCol3) = alOrder(lThisCol3 + 1) Next 'Copy pointer into new position alOrder(lThisCol2) = lPtr lSortedCount = lSortedCount + 1 'Go back to the previous row lThisCol = lThisCol - 1 End If Next Loop While lSortedCount End If '---Order Array Items ReDim avOutput(lStartRow To lNumRows, lStartCol To lNumCols) For lThisCol = lStartCol To lNumCols lPointer = alOrder(lThisCol) For lThisRow = lStartRow To lNumRows avOutput(lThisRow, lThisCol) = avValues(lThisRow, lPointer) Next Next '---Copy Sorted Values Back into avValues On Error GoTo ArrayDimmed avValues = avOutput Exit Function ArrayDimmed: 'The input parameter is not a variant array, copy the values in manually For lThisRow = lStartRow To lNumRows For lThisCol = lStartCol To lNumCols avValues(lThisRow, lThisCol) = avOutput(lThisRow, lThisCol) Next Next Exit Function ErrFailed: Debug.Print "Error in Array2dSortRows: " & Err.Description Debug.Assert False End Function
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
