Global variables , Range.Sort comparison routine , required Function , and Calling routine for recursion routine
( Recursion routine is here : http://www.excelfox.com/forum/showth...ll=1#post11058 )
Global variables , Range.Sort comparison routine , required Function
Code:Option Explicit Dim Cms() As Variant, Rs() As Variant ' "Horizointal Column" Indicies , "Virtical row" Indicies ' Dim RngToSort As Range ' Test data range for Sub SimpleArraySort7() Dim arrOrig() As Variant ' This arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range ' Dim arrIndx() As Variant ' For Sub SimpleArraySort7() Sub ReorgBy3Criteria() Rem 0 error handling On Error GoTo TheEnd: Rem 1 worksheet info ' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "") Set wksToSort = ThisWorkbook.Worksheets("Sheet1") Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3482 '454 '99 Dim RngToSort As Range: Set RngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters Dim ArrrngOrig() As Variant: Let ArrrngOrig() = RngToSort.Value ' This is used as a back up to restore the original range Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet Rem 3 VBA Range.Sort Method ' xlDescending Biggest at Top H Kcal J Fett L eiweiss 'rngToSort.Sort Key1:=wksToSort.Columns("h"), order1:=xlDescending, Key2:=wksToSort.Columns("j"), order2:=xlDescending, Key3:=wksToSort.Columns("l"), order3:=xlDescending 'X Nat 'Standard unter ---- Kcal Highest H ,at Top , second most J Fett , highest at Top , third Natrium X , most at top Dim StartTime As Double: Let StartTime = Timer RngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat MsgBox Prompt:=Round(Timer - StartTime, 2) Let Application.EnableEvents = True Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no" Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options. If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If ' all is well - carry on after End If Else Let Application.EnableEvents = False Let RngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was Let Application.EnableEvents = True End If Exit Sub ' Routine end if no errors____________________________________________________________________ TheEnd: ' Error handling code section Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description End Sub 'ReorgBy3Criteria ' Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html 'Dim rest As Long 'Variable for what is "left over" after subtracting as many full 26's as possible Do ' Let rest = ((lclm - 1) Mod 26) 'Gives 0 to 25 for Column Number "Left over" 1 to 26. Better than ( lclm Mod 26 ) which gives 1 to 25 for clm 1 to 25 then 0 for 26 ' Let FukOutChrWithDoWhile = Chr(65 + rest) & FukOutChrWithDoWhile 'Convert rest to Chr Number, initially with full number so the "units" (0-25), then number of 26's left over (if the number was so big to give any amount of 26's in it, then number of 26's in the 26's left over (if the number was so big to give any amount of 26 x 26's in it, Enit ? ' 'OR Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest. 'lclm = (lclm - (rest + 1)) \ 26 ' As the number is effectively truncated here, any number from 1 to (rest +1) will do in the formula Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it End Function
Calling routine for recursion routine
Code:' Calling code for the main Array sort routine Sub CallArraySort8() Rem 0 error handling 'On Error GoTo TheEnd: Rem 1 worksheet info ' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "") Set wksToSort = ThisWorkbook.Worksheets("Sheet1") Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3488 ' 3482 '454 '99 Dim RngToSort As Range: Set RngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters Dim ArrrngOrig() As Variant: Let ArrrngOrig() = RngToSort.Value ' This is used as a back up to restore the original range 'Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet '2b Initial Rs() indicies and required sequential column indicies, Cms(), and original data range arrOrig() - these are global variables Let Cms() = Evaluate("=Column(" & CL(1) & ":" & CL(RngToSort.Columns.Count) & ")") Let Rs() = Evaluate("=Row(1:" & RngToSort.Rows.Count & ")") Let arrOrig() = ArrrngOrig() ' Direct assignment to a dynamic array is possible, we use variant types because the Index returns variant types, and we also needed variant for the range capture using .Value as this also returns variant types. hence we can assign the arrays to eachother as they have similar types Rem 3 Array sort routine alternative coding '3a) arguments for Called routine Dim cnt As Long, strIndcs As String: Let strIndcs = " " For cnt = 1 To RngToSort.Rows.Count Let strIndcs = strIndcs & cnt & " " Next cnt Debug.Print strIndcs Dim arrTS() As Variant ' : Let arrTS() = ArrrngOrig() ' '3c) alternative '3b) Do sort ' Call SimpleArraySort8(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc ") ' '3c) alternative ' Let rngToSort.Value = arrTS() ' '3c) alternative '3c) Let Application.EnableEvents = False Dim StartTime As Double: Let StartTime = Timer arrTS() = RngToSort.Value: Call SimpleArraySort8(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): RngToSort.Value = arrTS() MsgBox Prompt:=Round(Timer - StartTime, 2) Let Application.EnableEvents = True Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no" Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options. If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If ' all is well - carry on after End If Else Let Application.EnableEvents = False Let RngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was Let Application.EnableEvents = True End If Exit Sub ' Routine end if no errors____________________________________________________________________ TheEnd: ' Error handling code section Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description End Sub ' Recursion routine is here : http://www.excelfox.com/forum/showth...ll=1#post11058 )
Reply With Quote
Bookmarks