March 2019 protokol Range.Sort method
Code:
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("" & DieseArbeitsmappe1.ProWb.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" & "")
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
rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
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.Value2 = 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
'
Range.Sort Pro routine and Calling code Sub CallArraySort()
Routines used to get results of next few post.
Code:
Option Explicit
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
rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
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
' https://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213887
'
' Calling code for the main Array sort routine
Sub CallArraySort()
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
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 SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc ") ' '3c) alternative
' Let rngToSort.Value = arrTS() ' '3c) alternative
'3c)
arrTS() = rngToSort.Value: Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): rngToSort.Value = arrTS()
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
Some timimg results. Range.Sort v Sub SimpleArraySort6(
The two codes are simply modified to give a time measurement thus:
Range.Sort Method:
Code:
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)
Array Sort coding ( In recursion code): ( Sub SimpleArraySort6( )
Code:
'3c)
Dim StartTime As Double: Let StartTime = Timer
arrTS() = rngToSort.Value: Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): rngToSort.Value = arrTS()
MsgBox prompt:=Round(Timer - StartTime, 2)
Part of original data test range
_____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )
| Row\Col |
H |
I |
J |
K |
W |
X |
Y |
824 |
338 |
|
0.1 |
|
|
0 |
|
825 |
|
|
|
|
|
|
|
826 |
351 |
|
0.1 |
|
|
|
|
827 |
342 |
|
0.1 |
|
|
0 |
|
828 |
342 |
|
0 |
|
|
|
|
829 |
341 |
|
0.1 |
|
|
0 |
|
830 |
338 |
|
1 |
|
|
0 |
|
831 |
338 |
|
0.1 |
|
|
0 |
|
832 |
338 |
|
0.1 |
|
|
0.1 |
|
833 |
337 |
|
0.5 |
|
|
0.1 |
|
834 |
337 |
|
0.1 |
|
|
0 |
|
835 |
337 |
|
0 |
|
|
0.1 |
|
836 |
336 |
|
0.2 |
|
|
0 |
|
837 |
335 |
|
0.1 |
|
|
0 |
|
838 |
334 |
|
0 |
|
|
0.1 |
|
839 |
333 |
|
0.2 |
|
|
0 |
|
840 |
332 |
|
0.2 |
|
|
0 |
|
841 |
332 |
|
0.1 |
|
|
0.1 |
|
842 |
332 |
|
0.1 |
|
|
0 |
|
843 |
331 |
|
0.1 |
|
|
0.1 |
|
844 |
331 |
|
0.1 |
|
|
0.1 |
|
845 |
329 |
|
0.2 |
|
|
0 |
|
846 |
329 |
|
0.1 |
|
|
0 |
|
847 |
326 |
|
0.3 |
|
|
0 |
|
848 |
326 |
|
0.3 |
|
|
0 |
|
849 |
326 |
|
0.2 |
|
|
0 |
|
850 |
326 |
|
0.1 |
|
|
0 |
|
851 |
324 |
|
0.1 |
|
|
0.1 |
|
852 |
324 |
|
0.1 |
|
|
0 |
|
853 |
319 |
|
0.2 |
|
|
0.1 |
|
854 |
318 |
|
0.5 |
|
|
0.1 |
|
855 |
316 |
|
0.2 |
|
|
0.1 |
|
856 |
279 |
|
0.5 |
|
|
0.1 |
|
857 |
232 |
|
0.1 |
|
|
0 |
|
858 |
230 |
|
0.2 |
|
|
0 |
|
859 |
215 |
|
0 |
|
|
0 |
|
860 |
|
|
|
|
|
|
|
861 |
338 |
|
0.1 |
|
|
0.1 |
|
862 |
339 |
|
0.1 |
|
|
0 |
|
863 |
337 |
|
0.1 |
|
|
0.1 |
|
864 |
|
|
|
|
|
|
|
865 |
338 |
|
1 |
|
|
0 |
|
Worksheet: Sheet1
"ProAktuellex8600x2SortTime.xlsm" https://app.box.com/s/af7891hzmd3sbfnnsmx5b28ktec6wwjo
Tests Range.Sort v Sub SimpleArraySort6( v Sub SimpleArraySort8(
These tests pick up the Thread from about here .._
http://www.excelfox.com/forum/showth...ll=1#post11043
_.. and use the same test range from there ( and in the uploaded file "ProAktuellex8600x2SortTime6_8.xlsm" )
Sub ReorgBy3Criteria()
The test routine for the Range.Sort , Sub ReorgBy3Criteria() , remains the same.
We need some global variables for Sub SimpleArraySort8(
Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "Horizointal Column" Indicies , "Virtical row" Indicies
Dim arrOrig() As Variant
These are important variables used in the = Application.Index(arrOrig(), Rs(), Cms()) code line, which applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range. A global variable is convenient for the constants of arrOrig() and all sequential column indicies, Cms() . Using a global variable for Rs() is a convenient alternative to passing its value through each recursion procedure copy Call
Within all copies of the recursion routine , arrIndx() is the important taken As Referred to array contain the current state of data range being sorted. At each column sort the row indices are sorted in parallel the column elements of only the column currently being sorted by. Then at the end of each sort the entire array, arrIndx() , gets updated through the use of
____ arrIndx() = Application.Index(arrOrig(), Rs(), Cms()).
This removes the need to do the sort on all columns during each sort: Only the column being used to determine the sorted order is re ordered, ( as well as the row indicie list in Rs() ). The remain columns get updated by the above formula
This is the main distinguishing characteristic of the Index idea way.
Sub CallArraySort8()
There is no significant change required here, since the signature line of Sub SimpleArraySort6( is in effect the same as. The only visible difference is the use of the array taken By Refer to , which is arrIndx() rather than arsRef() in Sub SimpleArraySort6( . But these are the variables that effectively “carry” internally the array carrying the current stand of the data range being constantly resorted. We pass to those , so there name to the Calling routine is irrelevant. These determine the name of the passes array as referred to within the respective routine. The only reason why we have different names is because in the intermediate solution, Sub SimpleArraySort7( , both ways were done in parallel for comparison of results, ( in terms of accuracy)
We have just a three things extra to do .
We must fill the two global variables Cms() and Rs()
Cms() needs filling once with a “horizontal” list of all sequential columns as all are referred to in every use of the = Application.Index(arrOrig(), Rs(), Cms()) code line.
The “vertical row” indices, Rs() , initially need filling with the full range row indices in the initial unsorted order
For convenience, both are filled using a spreadsheet function as discussed here http://www.excelfox.com/forum/showth...ll=1#post11051
The global variable for the original range of data , arrOrig() , also needs to be filled.
( We note that we could use this in place of the ArrrngOrig() which we have to restore our original range if we do not accept the resorted range. But for consistency with the previous coding we will not change this at this stage )
Coding in next posts
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg. 9hrvbYRwXvg9ht4b7z00X0
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg. 9hrehNPPnBu9ht4us7TtPr
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg. 9hr503K8PDg9ht5mfLcgpR
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htJ6TpIOXR
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htOKs4jh3M
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg. 9htWqRrSIfP9i-fyT84gqd
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg. 9htWqRrSIfP9i-kIDl-3C9
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg. 9i5yTldIQBn9i7NB1gjyBk
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg. 9i5jEuidRs99i7NUtNNy1v
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg. 9i3IA0y4fqp9i7NySrZamd
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9i7Qs8kxEqH
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9i7TqGQYqTz
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAJSNws8Zz
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAJvZ6kmlx
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAK0g1dU7i
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAKCDqNmnF
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAKHVSTGHy
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAKSBKPcJ6
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAKgL6lrcT
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAKlts8hKZ
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAKrX7UPP0
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg. 9hwsCHaKX6A9iAL5MSjWpA