Multiple Apps

Sorting an array with multiple dimensions (matrix)

Ease of Use

Intermediate

Version tested with

2000, 2003 

Submitted by:

MWE

Description:

Sorts virtually any data type in ascending or descending order. If the array to be sorted is a matrix, e.g., X(N,M) one index value for M is designated as the target or sort index and the rest of the data retains correct position. 

Discussion:

Many applications require that data be sorted in some way. This version of the common ?bubble sort? method offers some advantages over most bubble sorting procedures: it will sort virtually any type of data, e.g., Boolean, Double, Integer, Real, Single or String; it will sort in ascending or descending order {default is ascending}; and, if the array to be sorted is a matrix, e.g., X(N,M), the procedure will sort based on one of the ?M?s? and retain correct data relationships in all other dimensions. It may be easiest to think about N being the ?rows? and M being the ?columns? of a spreadsheet; any column can be the column used for sorting. MatrixSort does nothing that cannot be done using Excel?s built-in sorting capability; and the bubble sort method is one of the slowest methods for large number of data points. The potential advantage to MatrixSort is that it is application independent and very easy to understand. The Excel-based example demonstrates most variable types and most options. 

Code:

instructions for use

			

Option Explicit Sub xlMatrixSort( _ Optional WhatData As String = "selection", _ Optional SortDir As String = "ask", _ Optional SortCol As Long = 1) ' '**************************************************************************************** ' Function: sets up MatrixSort, interacting with user as required ' Passed Values: ' WhatData [in, string, OPTIONAL] defines whatdata is to be sorted, i.e., ' the whole spreadsheet (useful piece) "all", or the current "selection"; ' default = current selection ' SortDir [in, string, OPTIONAL] sorting direction; valid values are ' "ascend" or "descend" or "ask"; {default = "ask") ' SortCol [in, long, OPTIONAL] column on which data is to be sorted; ' default = 1 ' '*************************************************************************************** ' ' Dim FirstCol As Long Dim FirstRow As Long Dim I As Long Dim J As Long Dim LastCol As Long Dim LastRow As Long Dim MsgBxRtn As VbMsgBoxResult Dim MsgBxTitle As String Dim NumCells As String Dim NumNonBlank As Integer Dim PerNonBlank As Single Dim strSortCol As String Dim Time1 As Single Dim Time2 As Single Dim SortTime As Double Dim X() Dim xlSheet As Worksheet MsgBxTitle = "Test of MatrixSort" ' ' load data to be sorted ' Set xlSheet = ActiveSheet Select Case LCase(WhatData) Case "selection" On Error GoTo ErrorHandling_BadSelection FirstRow = Selection.Row LastRow = FirstRow + Selection.Rows.Count - 1 FirstCol = Selection.Column LastCol = FirstCol + Selection.Columns.Count - 1 Case "all" FirstRow = 2 FirstCol = 1 LastRow = xlLastRow LastCol = xlLastCol Case Else MsgBox "Invalue value for arguement 'WhatData'" & vbCrLf & _ "Acceptable values are 'all' and 'selection'" & vbCrLf & _ "Value passed is " & WhatData & vbCrLf & vbCrLf & _ "No sorting done.", vbCritical + vbOKOnly, MsgBxTitle Exit Sub End Select ' ' ReDim X based on data range ' ReDim X(LastRow - FirstRow + 1, LastCol - FirstCol + 1) ' ' read data into X ' NumCells = 0 NumNonBlank = 0 For I = FirstRow To LastRow For J = FirstCol To LastCol NumCells = NumCells + 1 If xlSheet.Cells(I, J).Text <> "" Then NumNonBlank = NumNonBlank + 1 X(I - FirstRow + 1, J - FirstCol + 1) = xlSheet.Cells(I, J) Next J Next I ' ' ensure that identified data is nontrivial ' If LastRow - FirstRow = 0 Then MsgBox "There is only one row for this sort." & _ vbCrLf & vbCrLf & "No sorting done", vbCritical, MsgBxTitle Exit Sub End If If LastRow - FirstRow + 1 < 5 Then MsgBxRtn = MsgBox("There are only " & (LastRow - FirstRow + 1) & " rows for " & _ "this sort." & _ vbCrLf & vbCrLf & "OK to continue?", vbQuestion + vbYesNo, MsgBxTitle) If MsgBxRtn <> vbYes Then Exit Sub End If PerNonBlank = 100# * (NumNonBlank / NumCells) If PerNonBlank < 75 Then MsgBxRtn = MsgBox(Format(PerNonBlank, "0") & " % of cells are nonblank." & _ vbCrLf & vbCrLf & "OK to continue?", vbQuestion + vbYesNo, MsgBxTitle) If MsgBxRtn <> vbYes Then Exit Sub End If ' ' if indicated, ask user about sorting parameters ' If SortDir = "ask" Then GetSortDir: SortDir = _ InputBox("enter sort direction: 'ascend' or 'descend'" & vbCrLf & vbCrLf & _ "{enter blank or 'end' or hit Cancel to quit}", MsgBxTitle) Select Case SortDir Case "", vbNullString, "end" Exit Sub Case "ascend", "descend" Case Else MsgBox "not valid response, try again", vbCritical + vbOKOnly, MsgBxTitle GoTo GetSortDir End Select GetSortCol: strSortCol = _ InputBox("enter sort column # [ " & FirstCol & "," & LastCol & " ]" & vbCrLf & vbCrLf & _ "{enter blank or 'end' or hit Cancel to quit}", MsgBxTitle) Select Case strSortCol Case "", vbNullString, "end" Exit Sub Case Is < FirstCol, Is > LastCol MsgBox "value must be in range " & FirstCol & " to " & LastCol & " try again", _ vbCritical + vbOKOnly, MsgBxTitle GoTo GetSortCol Case Else SortCol = strSortCol End Select Else SortCol = 1 End If ' ' sort data ' Time1 = Time Call MatrixSort(X, LastRow - FirstRow + 1, SortDir, LastCol - FirstCol + 1, SortCol) Time2 = Time SortTime = 24# * 3600# * (Time2 - Time1) ' ' replace data ' For I = FirstRow To LastRow For J = FirstCol To LastCol xlSheet.Cells(I, J) = X(I - FirstRow + 1, J - FirstCol + 1) Next J Next I MsgBox "Time to sort was " & Format(SortTime, "0.000") & " sec", _ vbInformation, MsgBxTitle Exit Sub ErrorHandling_BadSelection: MsgBox "invalid selection. No sorting done", vbCritical + vbOKOnly, MsgBxTitle End Sub Sub MatrixSort(X, NumRows, _ Optional SortDir As String = "ascend", _ Optional NumCols As Long = 1, _ Optional SortCol As Long = 1) ' '**************************************************************************************** ' Function: sorts virtually any data array or matrix based on a target ' "sorting column" ' Passed Values: ' X [in/out, any] array of values dimensioned at [NumRows,NumCols] ' NumRows [in, long] length of X ' SortDir [in, string, OPTIONAL] sorting direction; valid values are ' "ascend" or "descend"; {default = "ascend") ' NumCols [in, long, OPTIONAL] number of "columns" or additional dimensions ' SortCol [in, long, OPTIONAL] column on which data is to be sorted; ' default = 1 ' '*************************************************************************************** ' ' Dim I As Long Dim J As Long Dim K As Long Dim Temp Select Case SortDir Case "ascend" For I = 1 To NumRows - 1 For J = I + 1 To NumRows If X(I, SortCol) > X(J, SortCol) Then For K = 1 To NumCols Temp = X(I, K) X(I, K) = X(J, K) X(J, K) = Temp Next K End If Next J Next I Case "descend" For I = 1 To NumRows - 1 For J = I + 1 To NumRows If X(I, SortCol) < X(J, SortCol) Then For K = 1 To NumCols Temp = X(I, K) X(I, K) = X(J, K) X(J, K) = Temp Next K End If Next J Next I End Select End Sub Function xlLastRow(Optional WorksheetName As String) As Long ' ' Function finds the last populated row in a worksheet ' ' If WorksheetName = vbNullString Then WorksheetName = ActiveSheet.Name With Worksheets(WorksheetName) xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _ xlWhole, xlByRows, xlPrevious).Row End With End Function Function xlLastCol(Optional WorksheetName As String) As Long ' ' Function finds the last populated col in a worksheet ' ' If WorksheetName = vbNullString Then WorksheetName = ActiveSheet.Name With Worksheets(WorksheetName) xlLastCol = .Cells.Find("*", .Cells(1), xlFormulas, _ xlWhole, xlByColumns, xlPrevious).Column End With End Function

How to use:

  1. Copy the above code.
  2. Open any workbook.
  3. Press Alt + F11 to open the Visual Basic Editor (VBE).
  4. In the left side window, hi-lite the target spreadsheet [it will likely be called VBAProject(filename.xls) where filename is the name of the spreadsheet]
  5. Select an existing code module for the target worksheet; or from the Insert Menu, choose Insert | Module.
  6. Paste the code into the right-hand code window.
  7. Close the VBE, save the file if desired.
  8. See ?Test The Code? below
 

Test the code:

  1. Open the example
  2. The example contains several worksheets, each with a different type of data to sort in column A plus other data in cols B, C and D; and a worksheet for general sorting.
  3. For each of the former, Click on one of the yellow command buttons to sort ascending or descending. The test procedure will read the sample data, call MatrixSort and post the sorted data back to the worksheet.
  4. For the GeneralSort tab, clicking on the yellow command button initiates a dialogue with the user during which either ascending or descending is selected and the sort column is specified. Once that is completed, the test procedure will read the sample data, call MatrixSort and post the sorted data back to the worksheet. Clicking on the blue command button initiates a similar dialogue but only the current selection is sorted.
  5. For either the ColA cases or the GeneralSort case, the user can add additional rows or additional columns, the test procedure will figure out what to do.
  6. NOTE: MatrixSort is a subroutine that is called by some parent procedure or application. Thus final testing will depend on how MatrixSort is to be used.
 

Sample File:

MatrixSort.zip 38.08KB 

Approved by mdmackillop


This entry has been viewed 142 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express