Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
2 Dim Array Sort, on any columns, ascend or descend. Guidance des
Hi All,
I need some help on the questions below 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 = " 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmn opqrstuvwxyz" _ & "!""#$%&'()*+,-./:;<=?@[\]^_`{|}~" Const DownTbl = "~9876543210ZYXWVUTSRQPONMLKJIHGFEDCBAzyxwvutsrqpo nmlkjihgfedcba" _ & "}|{`_^]\[@?=<;:/.-,+*)('&%$#""! " 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 Text versus Binary if it's NEEDED. '' If NotUsedYetCompare = vbDatabaseCompare Then '' WarnErrMsg = WarnErrMsg _ '' & "Warning, vbDatabaseCompare changed to vbTextCompare" & vbCr '' NotUsedYetCompare = vbTextCompare '' End If Return EditMo '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 -- Neal Z |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
how do you sort ascend two columns alphabetically | New Users to Excel | |||
I need a sort to descend and ascend simultaneously | Excel Worksheet Functions | |||
Can you sort your sheet tabs in your workbook to ascend alphabetic | Excel Discussion (Misc queries) | |||
How do I sort ascend from highest to lowest | Excel Discussion (Misc queries) | |||
Sort on two columns in two dimensional array | Excel Programming |