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
|