Option Explicit
Sub xlMatrixSort( _
Optional WhatData As String = "selection", _
Optional SortDir As String = "ask", _
Optional SortCol As Long = 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"
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(LastRow - FirstRow + 1, LastCol - FirstCol + 1)
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
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 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
Time1 = Time
Call MatrixSort(X, LastRow - FirstRow + 1, SortDir, LastCol - FirstCol + 1, SortCol)
Time2 = Time
SortTime = 24# * 3600# * (Time2 - Time1)
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)
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
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
If WorksheetName = vbNullString Then WorksheetName = ActiveSheet.Name
With Worksheets(WorksheetName)
xlLastCol = .Cells.Find("*", .Cells(1), xlFormulas, _
xlWhole, xlByColumns, xlPrevious).Column
End With
End Function
|