N
Neal Zimm
Hi All,
I need some help on the questions below re: the attached function which I
developed, (my App needs it and I couldn't find it elsewhere) and which is
working OK so far in the testing.
It sorts a 2 dimen array, on any or all of its columns, ascending or
descending for each column to be part of the sort. The essence of the design
is that a sort key is built, an array of keys is sorted, and then used to
rewrite the incoming array.
Q1. So far, I don't need to sort numerics with decimal values, so the
function does NOT do this, (decimals are stripped) but this could be needed
so ..... What's the best way ? My inclination is that since the programmer
knows what should be in the array, adding a sort parm for a fixed # of
decimal positions to be used in the key should not be a hardship. Your
comments ? (e.g. if it's a date, 9 decimals are needed to get
accuracy of 1 second.) The BuildItemId: paragraph is where I think this
should happen.
Q2. What are the pro's and cons, and is it worth the effort in your
experience, to mimic the alpha nature of sorting via worksheet where a b A B
sort to A a B b ? I was getting A B a b and with help on this community, I
worked around it. My App does not need to differentiate data via its U or L
case, but what is your experience with this?
Q3. I've attached a test Sub with some data, and you should be able to run
it as is. If you'd like to comment generally, it would also be much
appreicated.
Note: re the bubble sort of the keys. I have a 10 yr old computer with a
pentium 386 chip. With a 500 row array, (about the upper limit for my app
that will use the function) it took .6603 seconds, and .6021 of it was the
bubble sort. I don't think my users will notice.
Thanks,
Neal Z.
Sub A_Test_Sort2DimenAy()
Dim vInAy As Variant
Dim WarnErrMsg As String
ReDim vInAy(11, 3)
vInAy(1, 1) = 10: vInAy(1, 2) = "hhhhh": vInAy(1, 3) = "ddd"
vInAy(2, 1) = 10: vInAy(2, 2) = "hhhhh": vInAy(2, 3) = "ddd"
vInAy(3, 1) = 10: vInAy(3, 2) = "BB": vInAy(3, 3) = "ddd"
vInAy(4, 1) = 2: vInAy(4, 2) = "zz": vInAy(4, 3) = "fff"
vInAy(5, 1) = 2: vInAy(5, 2) = "BBB": vInAy(5, 3) = "fff"
vInAy(6, 1) = 1: vInAy(6, 2) = "jjj": vInAy(6, 3) = "ddd"
vInAy(7, 1) = 9: vInAy(7, 2) = "BB": vInAy(7, 3) = "ddd"
vInAy(8, 1) = 1: vInAy(8, 2) = "zzzz": vInAy(8, 3) = "fff"
vInAy(9, 1) = 2: vInAy(9, 2) = "BB": vInAy(9, 3) = "eee"
vInAy(10, 1) = 2: vInAy(10, 2) = "jjj": vInAy(10, 3) = "ddd"
vInAy(11, 1) = 6: vInAy(11, 2) = "BBB": vInAy(11, 3) = "ddd"
WarnErrMsg = "1,11" 'see function re debug.print
'sort parms major to minor: column 2 descending, columns 3 and 1 ascending
vInAy = Sort2DimenAyF(vInAy, vbBinaryCompare, WarnErrMsg, _
"2, 2 , 3, 1, 1, 1")
If WarnErrMsg <> "" Then
Debug.Print WarnErrMsg
If InStr(WarnErrMsg, "warning") > 0 Then
MsgBox WarnErrMsg, vbExclamation, "Sort a 2 Dimen Array"
ElseIf InStr(WarnErrMsg, "error") > 0 Then
MsgBox "Sort Did NOT Exec" & vbCr & WarnErrMsg, vbCritical, _
"Sort a 2 Dimen Array"
'Do what you want
End If
End If
End Sub
Public Function Sort2DimenAyF(vInAy As Variant, _
NotUsedYetCompare As VbCompareMethod, _
WarnErrMsg As String, _
ParamArray SortParms()) As Variant
' Outputs: Function returns a 2 dimen array with its rows sorted via values
in any
'of its columns.
' WarnErrMsg, Null= no warnings and no errors. Not "", it will contain
'error or warning message. (Will contain "error" or "warning" as text part.
Any
'parm error stops the function and vInAy is returned unchanged. See Inputs
notes
're incoming value for Debug prints.
'
' Inputs: vInAy, the Ay to be sorted, rectangular, each row with same Qty
'of Columns.
'---------------------------------------
' NotUsedYetCompare, vbBinaryCompare is forced. Need it for descending
values.
'Still working out how to mimic worksheet sort where a,b,A,B sorts A,a,B,a
'Binary sort here gave A,B,a,b. See Sort_KeyAy: para for UCase use. The
EFFECT
'in this function for alpha data is a Text sort.
'---------------------------------------
' SortParms ParamArray; Each Ay column in the sort requires two items;
' 1,2 1st digit is column# number, 2nd is 1 for ascend, 2 for descend.
' 1st pair of items is major sort, with other pairs leading to most minor
' going left to right.
' e.g. call stmt for 2 col sort, Major: Col 4 descend, Minor: Col 1 ascend.
' vInAy = Sort2DimenAyF(vInAy, vbBinaryCompare, WarnErrMsg, 4, 2, 1, 1)
'------------ OR
'IF SortParms has only 1 element, it must be:
' (a) 1 dimen Ay with an even # of items in the same format.
' (b) a CSV string in same format, e.g. "4,2,1,1"
'----------------------------------
'(a) Dim ArgAy As Variant
' ArgAy = Array(4,2,1,1) or ArgAy = split("4,2,1,1",",")
' vInAy = Sort2DimenAyF(vInAy, vbTextBinary, WarnErrMsg, ArgAy)
' OR
'(b) Dim sParms As String
' sParms = "4,2,1,1"
' vInAy = Sort2DimenAyF(vInAy, vbBinaryCompare, WarnErrMsg, sParms)
'---------------------------------------------------------
' WarnErrMsg, Null incoming value = NO debug printing. For "x,y" layout
where x is
' the 'from' vInAy row# and y = the 'to' #, will show before/after key
values and the
' data from the sort columns. If "x,y" is invalid, brief debug.print message
issued.
'---------------------------------------------------
' Notes: My App arrays are small, (less than 500 rows) a bubble sort is
'used. You can sort the KeyAy array in the Sort_KeyAy paragraph any way you
'want by replacing the provided sort. ALWAYS sort the keys ascending.
' For a 'real' variant input vInAy, a vbEmpty item in a column to be sorted
'is treated as zero when that column's values are numeric or vbEmpty.
Otherwise
'a vbEmpty Ay item is treated as "".
' The sort currently supports ONLY integer or long numeric data types in a
'column Id'd for numeric sort criteria. If other numeric data types are found,
'the decimal portion is stripped in making the sort key. 1st situation is
warned.
' Any data element in a 'sort column' of vInAy that is not numeric, not a
'string holding all numeric characters, and not a 'regular' string will be
'treated as 0 or "". 1st situation will be warned.
'------------------------------------------------------
Const Title = "Sort a 2 Dimension Array"
Const UpTbl = "
0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" _
& "!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~"
Const DownTbl =
"~9876543210ZYXWVUTSRQPONMLKJIHGFEDCBAzyxwvutsrqponmlkjihgfedcba" _
& "}|{`_^]\[@?>=<;:/.-,+*)('&%$#""! "
Const OddCharMsg = "Warning, non-keyboard character found in a sort column
of input array." _
& vbCr & "The descending sort sequence may be affected. "
Const DeciMsg = "Warning, decimal portion of number was eliminated in a sort
column." _
& vbCr & "The sort sequence may be affected. This is the first, there may
be others." & vbCr
Const DataMsg = "Warning, UN-supported data type found in a sort column." _
& vbCr & "The sort sequence may be affected. This is the first, there may
be others." & vbCr
Dim KeyAy() As String 'holds the composed key
Dim Msg As String
Dim OneChar As String
Dim sHold As String
Dim sHoldAy() As String
Dim bDataMsg As Boolean 'msg switch
Dim bDeciMsg As Boolean 'msg switch
Dim bNotPrintChar As Boolean 'msg switch
Dim bNumeric As Boolean 'item to become part of key for sort
'T= entire Ay column is numeric.(vbEmpty items OK, but are changed for key
build)
Dim bNumerColAy() As Boolean
Const Ascend = 1, Descend = 2
Dim AscOrDesAy() As Long 'Ascend or Descend column
Dim AyCol As Long
'1 element for each 'sort' column, major to minor, via ParamArray.
Dim ColNumAy() As Long
'Dim BegTime As Double, EndTime As Double
Dim ColMajToMin As Long
Dim ColQty As Long
Dim DebugLOrow As Long, DebugHIrow As Long
Dim HIcol As Long, HIrow As Long
Dim iRowWide As Long
Dim Ix As Long
Dim iVarType As Integer
Dim Jx As Long
Dim lLen As Long
Dim LOcol As Long, LOrow As Long
Dim MaxLenAy() As Long 'Maximum Len item in the column
Dim MiscNum As Long
Dim Row As Long
Dim RowQty As Long
Dim ParmAy As Variant
Dim vOutAy As Variant
Dim vValue As Variant
'mainline start
GoSub Edit_InputParmValues
GoSub Build_KeyAy
If DebugHIrow > 0 Then Msg = "Before": GoSub zTestPrintKeyAy
GoSub Sort_KeyAy
If DebugHIrow > 0 Then Msg = "After": GoSub zTestPrintKeyAy
GoSub Write_Output
If DebugHIrow > 0 Then GoSub zTestPrintAyCols
Sort2DimenAyF = vOutAy
'mainline end
Exit Function
Build_KeyAy: ' 2 passes of input vInAy. Key will be SAME width for each
'row of input. Input Array Row# appended @key's right to keep the input
'sequence on sort key "ties".
'Pass 1, numeric nature of column, array items, max width of data.
For ColMajToMin = 1 To ColQty
AyCol = ColNumAy(ColMajToMin)
For Row = LOrow To HIrow
vValue = vInAy(Row, AyCol)
GoSub BuildItemId 'f odd ball items have sort key value adjusted.
If bNumerColAy(ColMajToMin) Then 'keep testing to turn it false.
If Not bNumeric Then bNumerColAy(ColMajToMin) = False
End If
'get widest item in the col to be sorted.
lLen = Len("" & vValue)
If lLen > MaxLenAy(ColMajToMin) Then MaxLenAy(ColMajToMin) = lLen
Next Row
Next ColMajToMin
ReDim KeyAy(LOrow To HIrow) 'array holding sort keys
RowQty = HIrow - LOrow + 1
iRowWide = Len("" & RowQty)
'pass 2, build sort key via parm columns.
For Row = LOrow To HIrow
For ColMajToMin = 1 To ColQty
AyCol = ColNumAy(ColMajToMin)
vValue = vInAy(Row, AyCol)
GoSub BuildItemId
sHold = Space(MaxLenAy(ColMajToMin))
If bNumeric Then
RSet sHold = ("" & vValue)
sHold = Replace(sHold, " ", "0")
Else
'A 65 Still working out whether or not it's worth the effort
'B 66 to mimic worksheet sort where sorted letters are AaBb
'a 97 Binary sort gives ABab on differing case input.
'b 98
LSet sHold = vValue
End If
If AscOrDesAy(ColMajToMin) = Descend Then GoSub BuildComplement
KeyAy(Row) = KeyAy(Row) & sHold
Next ColMajToMin
'Append row# @rightmost part of key
sHold = Space(iRowWide)
RSet sHold = ("" & Row)
sHold = Replace(sHold, " ", "0")
KeyAy(Row) = KeyAy(Row) & sHold
Next Row
Return
BuildComplement: 'sHold is changed. The KeyAy sort is Ascending, get
complementary
'characters for a descending column.
If bNumeric Then ' 9's complement
For Ix = 1 To Len(sHold)
OneChar = Mid(sHold, Ix, 1)
Mid(sHold, Ix, 1) = 9 - Val(OneChar)
Next Ix
Else 'substitute DownTbl char from UpTbl char
For Ix = 1 To Len(sHold)
Jx = InStr(1, UpTbl, Mid(sHold, Ix, 1), vbBinaryCompare)
If Jx > 0 Then 'printable char found in table
Mid(sHold, Ix, 1) = Mid(DownTbl, Jx, 1)
Else 'not a print character pick highest print value. 'todo prod,
remove???
Mid(sHold, Ix, 1) = "~" ' "highest" of all print chars ascii#
value
If Not bNotPrintChar Then
Msg = OddCharMsg & "Array row " & Row & ", column " & AyCol
& "." & vbCr
MsgBox Msg, vbExclamation, Title
WarnErrMsg = WarnErrMsg & Msg
bNotPrintChar = True
End If
End If
Next Ix
End If
Return
BuildItemId: 'Adjust iVarType and vValue for data the sort key value does
not support.
'Assign bNumeric for left or right alignment in vValue's portion of the sort
key.
'"Ignore" others if in a sort column. Ignored data types should not be in a
sort column,
'but adjust to keep the sort alive.
'docix=Sort Quirks,Data in a 2 Dimen Array;Data Types,Adjustments re Sort 2
Dimen Array
'docix=Sort Devel,BuildItemId: para to support decimals;'todo future
iVarType = VarType(vValue)
Select Case iVarType 'item in AyCol for its sort key value
Case 2, 3, 8 'f as is sort key value; Integer 2, Long 3, String 8
bNumeric = True
If iVarType = vbString And Not IsNumeric(vValue) Then bNumeric = False
Case 4 To 7, 14 'f single 4, double 5, currency 6, date 7, decimal 14
'f Numeric, but strip decimal, sort does not yet support #'s with decimals.
'f How to judge width? All decimals ?, most ? fixed# of places?. 'todo
future,
If Not bDeciMsg Then
Msg = "Array row " & Row & ", column " & AyCol & ", " & Format(vValue,
"0.00000") _
& " = # to 5 decimals, all decimals are stripped." & vbCr
Msg = DeciMsg & Msg
MsgBox Msg, vbExclamation, Title
WarnErrMsg = WarnErrMsg & Msg
bDeciMsg = True
End If
vValue = Int(vValue)
bNumeric = True
Case Else 'f All other data types. Keep numeric designation of the column
and vValue
'f will = 0 or "" for building the sort key. empty 0, null 1, Object 9,
Error 10,
'f Boolean 11, Variant 12, DataObject 13, Byte 17, UserDef 36, Array 8192
If Not bDataMsg Then
Msg = "VarType of the data is " & iVarType & " . Array row " _
& Row & " , column " & AyCol & vbCr
Msg = DataMsg & Msg
MsgBox Msg, vbExclamation, Title
WarnErrMsg = WarnErrMsg & Msg
bDataMsg = True
End If
bNumeric = bNumerColAy(ColMajToMin)
If bNumeric Then vValue = 0 Else vValue = ""
iVarType = VarType(vValue)
End Select
Return
Edit_InputParmValues: 'even # of parms in paramarray, sort columns are
within bounds,
'ascend and descend codes are valid. Debug.Print rows edits.
If Not IsArray(vInAy) Then
WarnErrMsg = "Error, Input is not an Array."
GoTo Quit
End If
On Error Resume Next
HIcol = UBound(vInAy, 2)
If Err <> 0 Then
WarnErrMsg = "Error, Input Array is not 2 Dimension."
GoTo Quit
Else
LOcol = LBound(vInAy, 2)
End If
LOrow = LBound(vInAy, 1) 'how big is input array
HIrow = UBound(vInAy, 1)
If (HIrow - LOrow + 1) = 1 Then
If WarnErrMsg <> "" Then Debug.Print vbCr & Title _
& ", 1 input array row, no sorting." & vbCr
WarnErrMsg = ""
GoTo Quit
End If
'---------------------
If WarnErrMsg <> "" Then
WarnErrMsg = Trim(WarnErrMsg)
sHoldAy = Split(WarnErrMsg, ",")
If UBound(sHoldAy) >= 1 Then
If IsNumeric(sHoldAy(0)) And IsNumeric(sHoldAy(1)) Then
If Val(sHoldAy(0)) <= Val(sHoldAy(1)) Then
DebugLOrow = sHoldAy(0) 'test print within array row bounds
If DebugLOrow < LOrow Then DebugLOrow = LOrow
DebugHIrow = sHoldAy(1)
If DebugHIrow > HIrow Then DebugHIrow = HIrow
Else
Debug.Print Title & " Ignored bad CSV debug print format,
'x,y' x is > y " _
& WarnErrMsg
End If
Else
Debug.Print Title & " Ignored bad CSV debug print format, 'x,y'
both not numeric, " _
& WarnErrMsg
End If
Else
Debug.Print Title & " Ignored bad CSV debug print format, " &
WarnErrMsg
End If
End If
WarnErrMsg = "" 'reset the parm for real warnings.
If LBound(SortParms) = UBound(SortParms) Then
If IsArray(SortParms(LBound(SortParms))) Then 'Ay of sort parms was
input
ParmAy = SortParms(LBound(SortParms))
GoSub EditMore
ElseIf InStr(SortParms(LBound(SortParms)), ",") > 0 Then
ParmAy = Split(SortParms(LBound(SortParms)), ",")
GoSub EditMore
Else
WarnErrMsg = "Error, ParamArray has Only 1 NOT-paired parm."
GoTo Quit
End If
ElseIf UBound(SortParms) < 0 Or (LBound(SortParms) = UBound(SortParms) _
And LBound(SortParms) = 0) Then
WarnErrMsg = "Error, ParamArray is Empty, no sort parms."
GoTo Quit
Else
ParmAy = SortParms
GoSub EditMore
End If
'' not yet, todo, choice re: Text versus Binary if it's NEEDED.
'' If NotUsedYetCompare = vbDatabaseCompare Then
'' WarnErrMsg = WarnErrMsg _
'' & "Warning, vbDatabaseCompare changed to vbTextCompare" & vbCr
'' NotUsedYetCompare = vbTextCompare
'' End If
Return
EditMore: 'Even # items, col#'s within bounds, ascend/desc codes OK.
MiscNum = UBound(ParmAy) - LBound(ParmAy) + 1
If MiscNum Mod 2 <> 0 Then
WarnErrMsg = "Error, Parm Count, " & MiscNum & ", is Not Even #."
GoTo Quit
End If
ColQty = MiscNum / 2
ReDim ColNumAy(ColQty) 'load input ay col#'s
ReDim AscOrDesAy(ColQty) 'up or down
ReDim bNumerColAy(ColQty) 'left or right set
ReDim MaxLenAy(ColQty) 'consistant key width
ColQty = 0
For Ix = LBound(ParmAy) To UBound(ParmAy) Step 2
ColQty = ColQty + 1
If IsNumeric(ParmAy(Ix)) Then
If LOcol <= ParmAy(Ix) And ParmAy(Ix) <= HIcol Then
ColNumAy(ColQty) = ParmAy(Ix)
Else
WarnErrMsg = "Error, Column# parm " & ParmAy(Ix) _
& ", Not Within column bounds of " _
& LOcol & " and " & HIcol & "."
GoTo Quit
End If
Else
WarnErrMsg = "Error, Column# parm " & ParmAy(Ix) & ", Not Numeric."
GoTo Quit
End If
If IsNumeric(ParmAy(Ix + 1)) Then
If ParmAy(Ix + 1) = Ascend Or ParmAy(Ix + 1) = Descend Then
AscOrDesAy(ColQty) = ParmAy(Ix + 1)
Else
WarnErrMsg = "Error, Column# " & ParmAy(Ix) _
& " Sort Spec is Not 1 for Ascend or 2 for Descend, it = " _
& ParmAy(Ix + 1)
GoTo Quit
End If
Else
WarnErrMsg = "Error, Column# " & ParmAy(Ix) _
& " Sort Spec is Not Numeric, it = " & ParmAy(Ix + 1)
GoTo Quit
End If
bNumerColAy(ColQty) = True 'disproven later
Next Ix
Return
Quit: 'Copy input and out
Sort2DimenAyF = vInAy
Exit Function
Return
Sort_KeyAy: 'Bubble sort the keys, see AaBb comment.
'' BegTime = microtimerf
For Ix = LOrow To (HIrow - 1)
For Jx = (Ix + 1) To HIrow
'If StrComp(UCase(KeyAy(Ix)), UCase(KeyAy(Jx)), NotUsedYetCompare) = 1 Then
If StrComp(UCase(KeyAy(Ix)), UCase(KeyAy(Jx)), vbBinaryCompare) = 1 Then
sHold = KeyAy(Jx)
KeyAy(Jx) = KeyAy(Ix)
KeyAy(Ix) = sHold
End If
Next Jx
Next Ix
'' EndTime = microtimerf
'' Call timerprint(BegTime, EndTime, " bubble sort time ")
Return
Write_Output: 'Use input Ay row# @ rightside of key to rewrite array.
vOutAy = vInAy 'Output Ay = image of the In.
For Ix = LOrow To HIrow 'Ix = new Key sequence
Row = Right(KeyAy(Ix), iRowWide) 'Row of vInAy
For AyCol = LOcol To HIcol
vOutAy(Ix, AyCol) = vInAy(Row, AyCol)
Next AyCol
Next Ix
Return
zTestPrintKeyAy:
Debug.Print vbCr & Title & " Macro Sort2DimenAyF"
Debug.Print "As Is Keys, " & Msg & " Sort"
'If NotUsedYetCompare = vbTextCompare Then Debug.Print "Text" _
Else Debug.Print "Binary"
Debug.Print "Binary"
If Msg = "before" Then
Debug.Print "Tracking rows " & DebugLOrow & " - " & DebugHIrow _
& ", Array Row#'s " & LOrow & " - " & HIrow
For Ix = DebugLOrow To DebugHIrow
Debug.Print KeyAy(Ix)
Next Ix
Else
Debug.Print Space(10) & "Sorted key row# at right"
MiscNum = 0
For Ix = LOrow To HIrow 'entire key array
Row = Right(KeyAy(Ix), iRowWide)
If DebugLOrow <= Row And Row <= DebugHIrow Then
Debug.Print KeyAy(Ix) & " " & Ix
MiscNum = MiscNum + 1
If MiscNum >= (DebugHIrow - DebugLOrow + 1) Then Exit For
End If
Next Ix
End If
Debug.Print "-------------------- " & Now & vbCr
Return
zTestPrintAyCols: 'Major to Minor sort cols data from output array
Debug.Print vbCr & "Output Array Row Sequence"
Debug.Print "Major to Minor Columns For Sort Key, A=Ascend D=Descend"
sHold = ""
For ColMajToMin = 1 To ColQty 'print Ay col#'s
vValue = Space(MaxLenAy(ColMajToMin))
AyCol = ColNumAy(ColMajToMin)
LSet vValue = ("" & AyCol)
sHold = sHold & vValue & " "
Next ColMajToMin
Debug.Print sHold: sHold = ""
For ColMajToMin = 1 To ColQty
If AscOrDesAy(ColMajToMin) = Ascend Then OneChar = "A" Else OneChar =
"D"
sHold = sHold & OneChar & Space(MaxLenAy(ColMajToMin)) '+1 space
implicit
Next ColMajToMin
sHold = sHold & " Input Ay Row#"
Debug.Print sHold: sHold = ""
Debug.Print "-------------------------------------"
MiscNum = 0
For Ix = LOrow To HIrow
Row = Right(KeyAy(Ix), iRowWide)
If DebugLOrow <= Row And Row <= DebugHIrow Then
For ColMajToMin = 1 To ColQty
AyCol = ColNumAy(ColMajToMin)
sHold = sHold & vOutAy(Ix, AyCol) & Space(MaxLenAy(ColMajToMin) _
- Len(vOutAy(Ix, AyCol)) + 1)
Next ColMajToMin
sHold = sHold & " " & Row
Debug.Print sHold: sHold = ""
MiscNum = MiscNum + 1
If MiscNum >= (DebugHIrow - DebugLOrow + 1) Then Exit For
End If
Next Ix
Debug.Print Title & " --Ended-- " & Now & vbCr
Return
End Function
I need some help on the questions below re: the attached function which I
developed, (my App needs it and I couldn't find it elsewhere) and which is
working OK so far in the testing.
It sorts a 2 dimen array, on any or all of its columns, ascending or
descending for each column to be part of the sort. The essence of the design
is that a sort key is built, an array of keys is sorted, and then used to
rewrite the incoming array.
Q1. So far, I don't need to sort numerics with decimal values, so the
function does NOT do this, (decimals are stripped) but this could be needed
so ..... What's the best way ? My inclination is that since the programmer
knows what should be in the array, adding a sort parm for a fixed # of
decimal positions to be used in the key should not be a hardship. Your
comments ? (e.g. if it's a date, 9 decimals are needed to get
accuracy of 1 second.) The BuildItemId: paragraph is where I think this
should happen.
Q2. What are the pro's and cons, and is it worth the effort in your
experience, to mimic the alpha nature of sorting via worksheet where a b A B
sort to A a B b ? I was getting A B a b and with help on this community, I
worked around it. My App does not need to differentiate data via its U or L
case, but what is your experience with this?
Q3. I've attached a test Sub with some data, and you should be able to run
it as is. If you'd like to comment generally, it would also be much
appreicated.
Note: re the bubble sort of the keys. I have a 10 yr old computer with a
pentium 386 chip. With a 500 row array, (about the upper limit for my app
that will use the function) it took .6603 seconds, and .6021 of it was the
bubble sort. I don't think my users will notice.
Thanks,
Neal Z.
Sub A_Test_Sort2DimenAy()
Dim vInAy As Variant
Dim WarnErrMsg As String
ReDim vInAy(11, 3)
vInAy(1, 1) = 10: vInAy(1, 2) = "hhhhh": vInAy(1, 3) = "ddd"
vInAy(2, 1) = 10: vInAy(2, 2) = "hhhhh": vInAy(2, 3) = "ddd"
vInAy(3, 1) = 10: vInAy(3, 2) = "BB": vInAy(3, 3) = "ddd"
vInAy(4, 1) = 2: vInAy(4, 2) = "zz": vInAy(4, 3) = "fff"
vInAy(5, 1) = 2: vInAy(5, 2) = "BBB": vInAy(5, 3) = "fff"
vInAy(6, 1) = 1: vInAy(6, 2) = "jjj": vInAy(6, 3) = "ddd"
vInAy(7, 1) = 9: vInAy(7, 2) = "BB": vInAy(7, 3) = "ddd"
vInAy(8, 1) = 1: vInAy(8, 2) = "zzzz": vInAy(8, 3) = "fff"
vInAy(9, 1) = 2: vInAy(9, 2) = "BB": vInAy(9, 3) = "eee"
vInAy(10, 1) = 2: vInAy(10, 2) = "jjj": vInAy(10, 3) = "ddd"
vInAy(11, 1) = 6: vInAy(11, 2) = "BBB": vInAy(11, 3) = "ddd"
WarnErrMsg = "1,11" 'see function re debug.print
'sort parms major to minor: column 2 descending, columns 3 and 1 ascending
vInAy = Sort2DimenAyF(vInAy, vbBinaryCompare, WarnErrMsg, _
"2, 2 , 3, 1, 1, 1")
If WarnErrMsg <> "" Then
Debug.Print WarnErrMsg
If InStr(WarnErrMsg, "warning") > 0 Then
MsgBox WarnErrMsg, vbExclamation, "Sort a 2 Dimen Array"
ElseIf InStr(WarnErrMsg, "error") > 0 Then
MsgBox "Sort Did NOT Exec" & vbCr & WarnErrMsg, vbCritical, _
"Sort a 2 Dimen Array"
'Do what you want
End If
End If
End Sub
Public Function Sort2DimenAyF(vInAy As Variant, _
NotUsedYetCompare As VbCompareMethod, _
WarnErrMsg As String, _
ParamArray SortParms()) As Variant
' Outputs: Function returns a 2 dimen array with its rows sorted via values
in any
'of its columns.
' WarnErrMsg, Null= no warnings and no errors. Not "", it will contain
'error or warning message. (Will contain "error" or "warning" as text part.
Any
'parm error stops the function and vInAy is returned unchanged. See Inputs
notes
're incoming value for Debug prints.
'
' Inputs: vInAy, the Ay to be sorted, rectangular, each row with same Qty
'of Columns.
'---------------------------------------
' NotUsedYetCompare, vbBinaryCompare is forced. Need it for descending
values.
'Still working out how to mimic worksheet sort where a,b,A,B sorts A,a,B,a
'Binary sort here gave A,B,a,b. See Sort_KeyAy: para for UCase use. The
EFFECT
'in this function for alpha data is a Text sort.
'---------------------------------------
' SortParms ParamArray; Each Ay column in the sort requires two items;
' 1,2 1st digit is column# number, 2nd is 1 for ascend, 2 for descend.
' 1st pair of items is major sort, with other pairs leading to most minor
' going left to right.
' e.g. call stmt for 2 col sort, Major: Col 4 descend, Minor: Col 1 ascend.
' vInAy = Sort2DimenAyF(vInAy, vbBinaryCompare, WarnErrMsg, 4, 2, 1, 1)
'------------ OR
'IF SortParms has only 1 element, it must be:
' (a) 1 dimen Ay with an even # of items in the same format.
' (b) a CSV string in same format, e.g. "4,2,1,1"
'----------------------------------
'(a) Dim ArgAy As Variant
' ArgAy = Array(4,2,1,1) or ArgAy = split("4,2,1,1",",")
' vInAy = Sort2DimenAyF(vInAy, vbTextBinary, WarnErrMsg, ArgAy)
' OR
'(b) Dim sParms As String
' sParms = "4,2,1,1"
' vInAy = Sort2DimenAyF(vInAy, vbBinaryCompare, WarnErrMsg, sParms)
'---------------------------------------------------------
' WarnErrMsg, Null incoming value = NO debug printing. For "x,y" layout
where x is
' the 'from' vInAy row# and y = the 'to' #, will show before/after key
values and the
' data from the sort columns. If "x,y" is invalid, brief debug.print message
issued.
'---------------------------------------------------
' Notes: My App arrays are small, (less than 500 rows) a bubble sort is
'used. You can sort the KeyAy array in the Sort_KeyAy paragraph any way you
'want by replacing the provided sort. ALWAYS sort the keys ascending.
' For a 'real' variant input vInAy, a vbEmpty item in a column to be sorted
'is treated as zero when that column's values are numeric or vbEmpty.
Otherwise
'a vbEmpty Ay item is treated as "".
' The sort currently supports ONLY integer or long numeric data types in a
'column Id'd for numeric sort criteria. If other numeric data types are found,
'the decimal portion is stripped in making the sort key. 1st situation is
warned.
' Any data element in a 'sort column' of vInAy that is not numeric, not a
'string holding all numeric characters, and not a 'regular' string will be
'treated as 0 or "". 1st situation will be warned.
'------------------------------------------------------
Const Title = "Sort a 2 Dimension Array"
Const UpTbl = "
0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" _
& "!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~"
Const DownTbl =
"~9876543210ZYXWVUTSRQPONMLKJIHGFEDCBAzyxwvutsrqponmlkjihgfedcba" _
& "}|{`_^]\[@?>=<;:/.-,+*)('&%$#""! "
Const OddCharMsg = "Warning, non-keyboard character found in a sort column
of input array." _
& vbCr & "The descending sort sequence may be affected. "
Const DeciMsg = "Warning, decimal portion of number was eliminated in a sort
column." _
& vbCr & "The sort sequence may be affected. This is the first, there may
be others." & vbCr
Const DataMsg = "Warning, UN-supported data type found in a sort column." _
& vbCr & "The sort sequence may be affected. This is the first, there may
be others." & vbCr
Dim KeyAy() As String 'holds the composed key
Dim Msg As String
Dim OneChar As String
Dim sHold As String
Dim sHoldAy() As String
Dim bDataMsg As Boolean 'msg switch
Dim bDeciMsg As Boolean 'msg switch
Dim bNotPrintChar As Boolean 'msg switch
Dim bNumeric As Boolean 'item to become part of key for sort
'T= entire Ay column is numeric.(vbEmpty items OK, but are changed for key
build)
Dim bNumerColAy() As Boolean
Const Ascend = 1, Descend = 2
Dim AscOrDesAy() As Long 'Ascend or Descend column
Dim AyCol As Long
'1 element for each 'sort' column, major to minor, via ParamArray.
Dim ColNumAy() As Long
'Dim BegTime As Double, EndTime As Double
Dim ColMajToMin As Long
Dim ColQty As Long
Dim DebugLOrow As Long, DebugHIrow As Long
Dim HIcol As Long, HIrow As Long
Dim iRowWide As Long
Dim Ix As Long
Dim iVarType As Integer
Dim Jx As Long
Dim lLen As Long
Dim LOcol As Long, LOrow As Long
Dim MaxLenAy() As Long 'Maximum Len item in the column
Dim MiscNum As Long
Dim Row As Long
Dim RowQty As Long
Dim ParmAy As Variant
Dim vOutAy As Variant
Dim vValue As Variant
'mainline start
GoSub Edit_InputParmValues
GoSub Build_KeyAy
If DebugHIrow > 0 Then Msg = "Before": GoSub zTestPrintKeyAy
GoSub Sort_KeyAy
If DebugHIrow > 0 Then Msg = "After": GoSub zTestPrintKeyAy
GoSub Write_Output
If DebugHIrow > 0 Then GoSub zTestPrintAyCols
Sort2DimenAyF = vOutAy
'mainline end
Exit Function
Build_KeyAy: ' 2 passes of input vInAy. Key will be SAME width for each
'row of input. Input Array Row# appended @key's right to keep the input
'sequence on sort key "ties".
'Pass 1, numeric nature of column, array items, max width of data.
For ColMajToMin = 1 To ColQty
AyCol = ColNumAy(ColMajToMin)
For Row = LOrow To HIrow
vValue = vInAy(Row, AyCol)
GoSub BuildItemId 'f odd ball items have sort key value adjusted.
If bNumerColAy(ColMajToMin) Then 'keep testing to turn it false.
If Not bNumeric Then bNumerColAy(ColMajToMin) = False
End If
'get widest item in the col to be sorted.
lLen = Len("" & vValue)
If lLen > MaxLenAy(ColMajToMin) Then MaxLenAy(ColMajToMin) = lLen
Next Row
Next ColMajToMin
ReDim KeyAy(LOrow To HIrow) 'array holding sort keys
RowQty = HIrow - LOrow + 1
iRowWide = Len("" & RowQty)
'pass 2, build sort key via parm columns.
For Row = LOrow To HIrow
For ColMajToMin = 1 To ColQty
AyCol = ColNumAy(ColMajToMin)
vValue = vInAy(Row, AyCol)
GoSub BuildItemId
sHold = Space(MaxLenAy(ColMajToMin))
If bNumeric Then
RSet sHold = ("" & vValue)
sHold = Replace(sHold, " ", "0")
Else
'A 65 Still working out whether or not it's worth the effort
'B 66 to mimic worksheet sort where sorted letters are AaBb
'a 97 Binary sort gives ABab on differing case input.
'b 98
LSet sHold = vValue
End If
If AscOrDesAy(ColMajToMin) = Descend Then GoSub BuildComplement
KeyAy(Row) = KeyAy(Row) & sHold
Next ColMajToMin
'Append row# @rightmost part of key
sHold = Space(iRowWide)
RSet sHold = ("" & Row)
sHold = Replace(sHold, " ", "0")
KeyAy(Row) = KeyAy(Row) & sHold
Next Row
Return
BuildComplement: 'sHold is changed. The KeyAy sort is Ascending, get
complementary
'characters for a descending column.
If bNumeric Then ' 9's complement
For Ix = 1 To Len(sHold)
OneChar = Mid(sHold, Ix, 1)
Mid(sHold, Ix, 1) = 9 - Val(OneChar)
Next Ix
Else 'substitute DownTbl char from UpTbl char
For Ix = 1 To Len(sHold)
Jx = InStr(1, UpTbl, Mid(sHold, Ix, 1), vbBinaryCompare)
If Jx > 0 Then 'printable char found in table
Mid(sHold, Ix, 1) = Mid(DownTbl, Jx, 1)
Else 'not a print character pick highest print value. 'todo prod,
remove???
Mid(sHold, Ix, 1) = "~" ' "highest" of all print chars ascii#
value
If Not bNotPrintChar Then
Msg = OddCharMsg & "Array row " & Row & ", column " & AyCol
& "." & vbCr
MsgBox Msg, vbExclamation, Title
WarnErrMsg = WarnErrMsg & Msg
bNotPrintChar = True
End If
End If
Next Ix
End If
Return
BuildItemId: 'Adjust iVarType and vValue for data the sort key value does
not support.
'Assign bNumeric for left or right alignment in vValue's portion of the sort
key.
'"Ignore" others if in a sort column. Ignored data types should not be in a
sort column,
'but adjust to keep the sort alive.
'docix=Sort Quirks,Data in a 2 Dimen Array;Data Types,Adjustments re Sort 2
Dimen Array
'docix=Sort Devel,BuildItemId: para to support decimals;'todo future
iVarType = VarType(vValue)
Select Case iVarType 'item in AyCol for its sort key value
Case 2, 3, 8 'f as is sort key value; Integer 2, Long 3, String 8
bNumeric = True
If iVarType = vbString And Not IsNumeric(vValue) Then bNumeric = False
Case 4 To 7, 14 'f single 4, double 5, currency 6, date 7, decimal 14
'f Numeric, but strip decimal, sort does not yet support #'s with decimals.
'f How to judge width? All decimals ?, most ? fixed# of places?. 'todo
future,
If Not bDeciMsg Then
Msg = "Array row " & Row & ", column " & AyCol & ", " & Format(vValue,
"0.00000") _
& " = # to 5 decimals, all decimals are stripped." & vbCr
Msg = DeciMsg & Msg
MsgBox Msg, vbExclamation, Title
WarnErrMsg = WarnErrMsg & Msg
bDeciMsg = True
End If
vValue = Int(vValue)
bNumeric = True
Case Else 'f All other data types. Keep numeric designation of the column
and vValue
'f will = 0 or "" for building the sort key. empty 0, null 1, Object 9,
Error 10,
'f Boolean 11, Variant 12, DataObject 13, Byte 17, UserDef 36, Array 8192
If Not bDataMsg Then
Msg = "VarType of the data is " & iVarType & " . Array row " _
& Row & " , column " & AyCol & vbCr
Msg = DataMsg & Msg
MsgBox Msg, vbExclamation, Title
WarnErrMsg = WarnErrMsg & Msg
bDataMsg = True
End If
bNumeric = bNumerColAy(ColMajToMin)
If bNumeric Then vValue = 0 Else vValue = ""
iVarType = VarType(vValue)
End Select
Return
Edit_InputParmValues: 'even # of parms in paramarray, sort columns are
within bounds,
'ascend and descend codes are valid. Debug.Print rows edits.
If Not IsArray(vInAy) Then
WarnErrMsg = "Error, Input is not an Array."
GoTo Quit
End If
On Error Resume Next
HIcol = UBound(vInAy, 2)
If Err <> 0 Then
WarnErrMsg = "Error, Input Array is not 2 Dimension."
GoTo Quit
Else
LOcol = LBound(vInAy, 2)
End If
LOrow = LBound(vInAy, 1) 'how big is input array
HIrow = UBound(vInAy, 1)
If (HIrow - LOrow + 1) = 1 Then
If WarnErrMsg <> "" Then Debug.Print vbCr & Title _
& ", 1 input array row, no sorting." & vbCr
WarnErrMsg = ""
GoTo Quit
End If
'---------------------
If WarnErrMsg <> "" Then
WarnErrMsg = Trim(WarnErrMsg)
sHoldAy = Split(WarnErrMsg, ",")
If UBound(sHoldAy) >= 1 Then
If IsNumeric(sHoldAy(0)) And IsNumeric(sHoldAy(1)) Then
If Val(sHoldAy(0)) <= Val(sHoldAy(1)) Then
DebugLOrow = sHoldAy(0) 'test print within array row bounds
If DebugLOrow < LOrow Then DebugLOrow = LOrow
DebugHIrow = sHoldAy(1)
If DebugHIrow > HIrow Then DebugHIrow = HIrow
Else
Debug.Print Title & " Ignored bad CSV debug print format,
'x,y' x is > y " _
& WarnErrMsg
End If
Else
Debug.Print Title & " Ignored bad CSV debug print format, 'x,y'
both not numeric, " _
& WarnErrMsg
End If
Else
Debug.Print Title & " Ignored bad CSV debug print format, " &
WarnErrMsg
End If
End If
WarnErrMsg = "" 'reset the parm for real warnings.
If LBound(SortParms) = UBound(SortParms) Then
If IsArray(SortParms(LBound(SortParms))) Then 'Ay of sort parms was
input
ParmAy = SortParms(LBound(SortParms))
GoSub EditMore
ElseIf InStr(SortParms(LBound(SortParms)), ",") > 0 Then
ParmAy = Split(SortParms(LBound(SortParms)), ",")
GoSub EditMore
Else
WarnErrMsg = "Error, ParamArray has Only 1 NOT-paired parm."
GoTo Quit
End If
ElseIf UBound(SortParms) < 0 Or (LBound(SortParms) = UBound(SortParms) _
And LBound(SortParms) = 0) Then
WarnErrMsg = "Error, ParamArray is Empty, no sort parms."
GoTo Quit
Else
ParmAy = SortParms
GoSub EditMore
End If
'' not yet, todo, choice re: Text versus Binary if it's NEEDED.
'' If NotUsedYetCompare = vbDatabaseCompare Then
'' WarnErrMsg = WarnErrMsg _
'' & "Warning, vbDatabaseCompare changed to vbTextCompare" & vbCr
'' NotUsedYetCompare = vbTextCompare
'' End If
Return
EditMore: 'Even # items, col#'s within bounds, ascend/desc codes OK.
MiscNum = UBound(ParmAy) - LBound(ParmAy) + 1
If MiscNum Mod 2 <> 0 Then
WarnErrMsg = "Error, Parm Count, " & MiscNum & ", is Not Even #."
GoTo Quit
End If
ColQty = MiscNum / 2
ReDim ColNumAy(ColQty) 'load input ay col#'s
ReDim AscOrDesAy(ColQty) 'up or down
ReDim bNumerColAy(ColQty) 'left or right set
ReDim MaxLenAy(ColQty) 'consistant key width
ColQty = 0
For Ix = LBound(ParmAy) To UBound(ParmAy) Step 2
ColQty = ColQty + 1
If IsNumeric(ParmAy(Ix)) Then
If LOcol <= ParmAy(Ix) And ParmAy(Ix) <= HIcol Then
ColNumAy(ColQty) = ParmAy(Ix)
Else
WarnErrMsg = "Error, Column# parm " & ParmAy(Ix) _
& ", Not Within column bounds of " _
& LOcol & " and " & HIcol & "."
GoTo Quit
End If
Else
WarnErrMsg = "Error, Column# parm " & ParmAy(Ix) & ", Not Numeric."
GoTo Quit
End If
If IsNumeric(ParmAy(Ix + 1)) Then
If ParmAy(Ix + 1) = Ascend Or ParmAy(Ix + 1) = Descend Then
AscOrDesAy(ColQty) = ParmAy(Ix + 1)
Else
WarnErrMsg = "Error, Column# " & ParmAy(Ix) _
& " Sort Spec is Not 1 for Ascend or 2 for Descend, it = " _
& ParmAy(Ix + 1)
GoTo Quit
End If
Else
WarnErrMsg = "Error, Column# " & ParmAy(Ix) _
& " Sort Spec is Not Numeric, it = " & ParmAy(Ix + 1)
GoTo Quit
End If
bNumerColAy(ColQty) = True 'disproven later
Next Ix
Return
Quit: 'Copy input and out
Sort2DimenAyF = vInAy
Exit Function
Return
Sort_KeyAy: 'Bubble sort the keys, see AaBb comment.
'' BegTime = microtimerf
For Ix = LOrow To (HIrow - 1)
For Jx = (Ix + 1) To HIrow
'If StrComp(UCase(KeyAy(Ix)), UCase(KeyAy(Jx)), NotUsedYetCompare) = 1 Then
If StrComp(UCase(KeyAy(Ix)), UCase(KeyAy(Jx)), vbBinaryCompare) = 1 Then
sHold = KeyAy(Jx)
KeyAy(Jx) = KeyAy(Ix)
KeyAy(Ix) = sHold
End If
Next Jx
Next Ix
'' EndTime = microtimerf
'' Call timerprint(BegTime, EndTime, " bubble sort time ")
Return
Write_Output: 'Use input Ay row# @ rightside of key to rewrite array.
vOutAy = vInAy 'Output Ay = image of the In.
For Ix = LOrow To HIrow 'Ix = new Key sequence
Row = Right(KeyAy(Ix), iRowWide) 'Row of vInAy
For AyCol = LOcol To HIcol
vOutAy(Ix, AyCol) = vInAy(Row, AyCol)
Next AyCol
Next Ix
Return
zTestPrintKeyAy:
Debug.Print vbCr & Title & " Macro Sort2DimenAyF"
Debug.Print "As Is Keys, " & Msg & " Sort"
'If NotUsedYetCompare = vbTextCompare Then Debug.Print "Text" _
Else Debug.Print "Binary"
Debug.Print "Binary"
If Msg = "before" Then
Debug.Print "Tracking rows " & DebugLOrow & " - " & DebugHIrow _
& ", Array Row#'s " & LOrow & " - " & HIrow
For Ix = DebugLOrow To DebugHIrow
Debug.Print KeyAy(Ix)
Next Ix
Else
Debug.Print Space(10) & "Sorted key row# at right"
MiscNum = 0
For Ix = LOrow To HIrow 'entire key array
Row = Right(KeyAy(Ix), iRowWide)
If DebugLOrow <= Row And Row <= DebugHIrow Then
Debug.Print KeyAy(Ix) & " " & Ix
MiscNum = MiscNum + 1
If MiscNum >= (DebugHIrow - DebugLOrow + 1) Then Exit For
End If
Next Ix
End If
Debug.Print "-------------------- " & Now & vbCr
Return
zTestPrintAyCols: 'Major to Minor sort cols data from output array
Debug.Print vbCr & "Output Array Row Sequence"
Debug.Print "Major to Minor Columns For Sort Key, A=Ascend D=Descend"
sHold = ""
For ColMajToMin = 1 To ColQty 'print Ay col#'s
vValue = Space(MaxLenAy(ColMajToMin))
AyCol = ColNumAy(ColMajToMin)
LSet vValue = ("" & AyCol)
sHold = sHold & vValue & " "
Next ColMajToMin
Debug.Print sHold: sHold = ""
For ColMajToMin = 1 To ColQty
If AscOrDesAy(ColMajToMin) = Ascend Then OneChar = "A" Else OneChar =
"D"
sHold = sHold & OneChar & Space(MaxLenAy(ColMajToMin)) '+1 space
implicit
Next ColMajToMin
sHold = sHold & " Input Ay Row#"
Debug.Print sHold: sHold = ""
Debug.Print "-------------------------------------"
MiscNum = 0
For Ix = LOrow To HIrow
Row = Right(KeyAy(Ix), iRowWide)
If DebugLOrow <= Row And Row <= DebugHIrow Then
For ColMajToMin = 1 To ColQty
AyCol = ColNumAy(ColMajToMin)
sHold = sHold & vOutAy(Ix, AyCol) & Space(MaxLenAy(ColMajToMin) _
- Len(vOutAy(Ix, AyCol)) + 1)
Next ColMajToMin
sHold = sHold & " " & Row
Debug.Print sHold: sHold = ""
MiscNum = MiscNum + 1
If MiscNum >= (DebugHIrow - DebugLOrow + 1) Then Exit For
End If
Next Ix
Debug.Print Title & " --Ended-- " & Now & vbCr
Return
End Function