Just testing. Testing some sort routines. No reply needed

In support of this Thread
http://www.excelfox.com/forum/showth...for-simple-use
Posts from approx
http://www.excelfox.com/forum/showth...ll=1#post11047

Initial test range

_____ ( Using Excel 2007 32 bit )

_Row\^Col
P

Q

R

S

T

U

V

W

21

22

1

2

3

4

5

6

23

1
Crisps Was S23
500
Was U23
0.7
Was W23

24

2
Beer Was S24
200
Was U24
0.1
Was W24

25

3
Wine Was S25
150
Was U25
0.15
Was W25

26

4
Beer Was S26
200
Was U26
0.07
Was W26

27

5
beer Was S27
220
Was U27
0.2
Was W27

28

6
Beer Was S28
210
Was U28
0.06
Was W28

29

7
Wine Was S29
160
Was U29
0.04
Was W29

30

8
wiNe Was S30
150
Was U30
0.03
Was W30

31

9
Crisps Was S31
502
Was U31
2
Was W31

32

10
Onion Ringes Was S32
480
Was U32
1
Was W32

33

11
Onion Ringes Was S33
490
Was U33
1.5
Was W33

34

12
Crisps Was S34
502
Was U34
1.5
Was W34

35

13
CRISPS Was S35
500
Was U35
1.1
Was W35

36

14
Wine Was S36
170
Was U36
0.1
Was W36

37

15
Crisps Was S37
500
Was U37
3
Was W37

Worksheet: Sorting

_Row\^Col	Q	R	S	T	U	V	W
21
22		1	2	3	4	5	6
23	1	Crisps	Was S23	500	Was U23	0.7	Was W23
24	2	Beer	Was S24	200	Was U24	0.1	Was W24
25	3	Wine	Was S25	150	Was U25	0.15	Was W25
26	4	Beer	Was S26	200	Was U26	0.07	Was W26
27	5	beer	Was S27	220	Was U27	0.2	Was W27
28	6	Beer	Was S28	210	Was U28	0.06	Was W28
29	7	Wine	Was S29	160	Was U29	0.04	Was W29
30	8	wiNe	Was S30	150	Was U30	0.03	Was W30
31	9	Crisps	Was S31	502	Was U31	2	Was W31
32	10	Onion Ringes	Was S32	480	Was U32	1	Was W32
33	11	Onion Ringes	Was S33	490	Was U33	1.5	Was W33
34	12	Crisps	Was S34	502	Was U34	1.5	Was W34
35	13	CRISPS	Was S35	500	Was U35	1.1	Was W35
36	14	Wine	Was S36	170	Was U36	0.1	Was W36
37	15	Crisps	Was S37	500	Was U37	3	Was W37

In support of this Thread
http://www.excelfox.com/forum/showth...for-simple-use
Posts from approx
http://www.excelfox.com/forum/showth...ll=1#post11047

Results up to just after first run of this section ( based on the initial unsorted test data range in last post )

Code:

' Captains Blog, Start Treck RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Clear Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Value = arsRef() RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Clear Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Value = arrIndx() RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Clear Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs() Debug.Print " Running Copy " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf

The second two ranges are produced form that ' Captains Blog, Start Treck. ( The first range is produced in the Calling routines, and tests the arrOut() = App.Indx( arrOrig() , {1;2;3;4 .....} , {1,2,3,4,5 ......} )
idea to reproduce the initial test range )
_____ ( Using Excel 2007 32 bit )

_Row\^Col
P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

38

1
Crisps Was S23
500
Was U23
0.7
Was W23

39

2
Beer Was S24
200
Was U24
0.1
Was W24

40

3
Wine Was S25
150
Was U25
0.15
Was W25

41

4
Beer Was S26
200
Was U26
0.07
Was W26

42

5
beer Was S27
220
Was U27
0.2
Was W27

43

6
Beer Was S28
210
Was U28
0.06
Was W28

44

7
Wine Was S29
160
Was U29
0.04
Was W29

45

8
wiNe Was S30
150
Was U30
0.03
Was W30

46

9
Crisps Was S31
502
Was U31
2
Was W31

47

10
Onion Ringes Was S32
480
Was U32
1
Was W32

48

11
Onion Ringes Was S33
490
Was U33
1.5
Was W33

49

12
Crisps Was S34
502
Was U34
1.5
Was W34

50

13
CRISPS Was S35
500
Was U35
1.1
Was W35

51

14
Wine Was S36
170
Was U36
0.1
Was W36

52

15
Crisps Was S37
500
Was U37
3
Was W37

53

3
Wine Was S25
150
Was U25
0.15
Was W25 Wine Was S25
150
Was U25
0.15
Was W25

54

7
Wine Was S29
160
Was U29
0.04
Was W29 Wine Was S29
160
Was U29
0.04
Was W29

55

8
wiNe Was S30
150
Was U30
0.03
Was W30 wiNe Was S30
150
Was U30
0.03
Was W30

56

14
Wine Was S36
170
Was U36
0.1
Was W36 Wine Was S36
170
Was U36
0.1
Was W36

57

11
Onion Ringes Was S33
490
Was U33
1.5
Was W33 Onion Ringes Was S33
490
Was U33
1.5
Was W33

58

10
Onion Ringes Was S32
480
Was U32
1
Was W32 Onion Ringes Was S32
480
Was U32
1
Was W32

59

9
Crisps Was S31
502
Was U31
2
Was W31 Crisps Was S31
502
Was U31
2
Was W31

60

12
Crisps Was S34
502
Was U34
1.5
Was W34 Crisps Was S34
502
Was U34
1.5
Was W34

61

13
CRISPS Was S35
500
Was U35
1.1
Was W35 CRISPS Was S35
500
Was U35
1.1
Was W35

62

1
Crisps Was S23
500
Was U23
0.7
Was W23 Crisps Was S23
500
Was U23
0.7
Was W23

63

15
Crisps Was S37
500
Was U37
3
Was W37 Crisps Was S37
500
Was U37
3
Was W37

64

2
Beer Was S24
200
Was U24
0.1
Was W24 Beer Was S24
200
Was U24
0.1
Was W24

65

4
Beer Was S26
200
Was U26
0.07
Was W26 Beer Was S26
200
Was U26
0.07
Was W26

66

5
beer Was S27
220
Was U27
0.2
Was W27 beer Was S27
220
Was U27
0.2
Was W27

67

6
Beer Was S28
210
Was U28
0.06
Was W28 Beer Was S28
210
Was U28
0.06
Was W28

68

Worksheet: Sorting
Second range left comes from arsRef() ___Range to right comes from arrIndx() = Application.Index(arrOrig(), Rs(), Cms())

_Row\^Col	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC
38	1	Crisps	Was S23	500	Was U23	0.7	Was W23
39	2	Beer	Was S24	200	Was U24	0.1	Was W24
40	3	Wine	Was S25	150	Was U25	0.15	Was W25
41	4	Beer	Was S26	200	Was U26	0.07	Was W26
42	5	beer	Was S27	220	Was U27	0.2	Was W27
43	6	Beer	Was S28	210	Was U28	0.06	Was W28
44	7	Wine	Was S29	160	Was U29	0.04	Was W29
45	8	wiNe	Was S30	150	Was U30	0.03	Was W30
46	9	Crisps	Was S31	502	Was U31	2	Was W31
47	10	Onion Ringes	Was S32	480	Was U32	1	Was W32
48	11	Onion Ringes	Was S33	490	Was U33	1.5	Was W33
49	12	Crisps	Was S34	502	Was U34	1.5	Was W34
50	13	CRISPS	Was S35	500	Was U35	1.1	Was W35
51	14	Wine	Was S36	170	Was U36	0.1	Was W36
52	15	Crisps	Was S37	500	Was U37	3	Was W37
53	3	Wine	Was S25	150	Was U25	0.15	Was W25	Wine	Was S25	150	Was U25	0.15	Was W25
54	7	Wine	Was S29	160	Was U29	0.04	Was W29	Wine	Was S29	160	Was U29	0.04	Was W29
55	8	wiNe	Was S30	150	Was U30	0.03	Was W30	wiNe	Was S30	150	Was U30	0.03	Was W30
56	14	Wine	Was S36	170	Was U36	0.1	Was W36	Wine	Was S36	170	Was U36	0.1	Was W36
57	11	Onion Ringes	Was S33	490	Was U33	1.5	Was W33	Onion Ringes	Was S33	490	Was U33	1.5	Was W33
58	10	Onion Ringes	Was S32	480	Was U32	1	Was W32	Onion Ringes	Was S32	480	Was U32	1	Was W32
59	9	Crisps	Was S31	502	Was U31	2	Was W31	Crisps	Was S31	502	Was U31	2	Was W31
60	12	Crisps	Was S34	502	Was U34	1.5	Was W34	Crisps	Was S34	502	Was U34	1.5	Was W34
61	13	CRISPS	Was S35	500	Was U35	1.1	Was W35	CRISPS	Was S35	500	Was U35	1.1	Was W35
62	1	Crisps	Was S23	500	Was U23	0.7	Was W23	Crisps	Was S23	500	Was U23	0.7	Was W23
63	15	Crisps	Was S37	500	Was U37	3	Was W37	Crisps	Was S37	500	Was U37	3	Was W37
64	2	Beer	Was S24	200	Was U24	0.1	Was W24	Beer	Was S24	200	Was U24	0.1	Was W24
65	4	Beer	Was S26	200	Was U26	0.07	Was W26	Beer	Was S26	200	Was U26	0.07	Was W26
66	5	beer	Was S27	220	Was U27	0.2	Was W27	beer	Was S27	220	Was U27	0.2	Was W27
67	6	Beer	Was S28	210	Was U28	0.06	Was W28	Beer	Was S28	210	Was U28	0.06	Was W28
68

Full run results ( For recursion routine )

_____ ( Using Excel 2007 32 bit )

3
Wine Was S25
150
Was U25
0.15
Was W25 Wine Was S25
150
Was U25
0.15
Was W25

7
Wine Was S29
160
Was U29
0.04
Was W29 Wine Was S29
160
Was U29
0.04
Was W29

8
wiNe Was S30
150
Was U30
0.03
Was W30 wiNe Was S30
150
Was U30
0.03
Was W30

14
Wine Was S36
170
Was U36
0.1
Was W36 Wine Was S36
170
Was U36
0.1
Was W36

11
Onion Ringes Was S33
490
Was U33
1.5
Was W33 Onion Ringes Was S33
490
Was U33
1.5
Was W33

10
Onion Ringes Was S32
480
Was U32
1
Was W32 Onion Ringes Was S32
480
Was U32
1
Was W32

9
Crisps Was S31
502
Was U31
2
Was W31 Crisps Was S31
502
Was U31
2
Was W31

12
Crisps Was S34
502
Was U34
1.5
Was W34 Crisps Was S34
502
Was U34
1.5
Was W34

13
CRISPS Was S35
500
Was U35
1.1
Was W35 CRISPS Was S35
500
Was U35
1.1
Was W35

1
Crisps Was S23
500
Was U23
0.7
Was W23 Crisps Was S23
500
Was U23
0.7
Was W23

15
Crisps Was S37
500
Was U37
3
Was W37 Crisps Was S37
500
Was U37
3
Was W37

2
Beer Was S24
200
Was U24
0.1
Was W24 Beer Was S24
200
Was U24
0.1
Was W24

4
Beer Was S26
200
Was U26
0.07
Was W26 Beer Was S26
200
Was U26
0.07
Was W26

5
beer Was S27
220
Was U27
0.2
Was W27 beer Was S27
220
Was U27
0.2
Was W27

6
Beer Was S28
210
Was U28
0.06
Was W28 Beer Was S28
210
Was U28
0.06
Was W28

8
wiNe Was S30
150
Was U30
0.03
Was W30 wiNe Was S30
150
Was U30
0.03
Was W30

3
Wine Was S25
150
Was U25
0.15
Was W25 Wine Was S25
150
Was U25
0.15
Was W25

7
Wine Was S29
160
Was U29
0.04
Was W29 Wine Was S29
160
Was U29
0.04
Was W29

14
Wine Was S36
170
Was U36
0.1
Was W36 Wine Was S36
170
Was U36
0.1
Was W36

10
Onion Ringes Was S32
480
Was U32
1
Was W32 Onion Ringes Was S32
480
Was U32
1
Was W32

11
Onion Ringes Was S33
490
Was U33
1.5
Was W33 Onion Ringes Was S33
490
Was U33
1.5
Was W33

1
Crisps Was S23
500
Was U23
0.7
Was W23 Crisps Was S23
500
Was U23
0.7
Was W23

13
CRISPS Was S35
500
Was U35
1.1
Was W35 CRISPS Was S35
500
Was U35
1.1
Was W35

15
Crisps Was S37
500
Was U37
3
Was W37 Crisps Was S37
500
Was U37
3
Was W37

12
Crisps Was S34
502
Was U34
1.5
Was W34 Crisps Was S34
502
Was U34
1.5
Was W34

9
Crisps Was S31
502
Was U31
2
Was W31 Crisps Was S31
502
Was U31
2
Was W31

2
Beer Was S24
200
Was U24
0.1
Was W24 Beer Was S24
200
Was U24
0.1
Was W24

4
Beer Was S26
200
Was U26
0.07
Was W26 Beer Was S26
200
Was U26
0.07
Was W26

6
Beer Was S28
210
Was U28
0.06
Was W28 Beer Was S28
210
Was U28
0.06
Was W28

5
beer Was S27
220
Was U27
0.2
Was W27 beer Was S27
220
Was U27
0.2
Was W27

8
wiNe Was S30
150
Was U30
0.03
Was W30 wiNe Was S30
150
Was U30
0.03
Was W30

3
Wine Was S25
150
Was U25
0.15
Was W25 Wine Was S25
150
Was U25
0.15
Was W25

7
Wine Was S29
160
Was U29
0.04
Was W29 Wine Was S29
160
Was U29
0.04
Was W29

14
Wine Was S36
170
Was U36
0.1
Was W36 Wine Was S36
170
Was U36
0.1
Was W36

10
Onion Ringes Was S32
480
Was U32
1
Was W32 Onion Ringes Was S32
480
Was U32
1
Was W32

11
Onion Ringes Was S33
490
Was U33
1.5
Was W33 Onion Ringes Was S33
490
Was U33
1.5
Was W33

1
Crisps Was S23
500
Was U23
0.7
Was W23 Crisps Was S23
500
Was U23
0.7
Was W23

13
CRISPS Was S35
500
Was U35
1.1
Was W35 CRISPS Was S35
500
Was U35
1.1
Was W35

15
Crisps Was S37
500
Was U37
3
Was W37 Crisps Was S37
500
Was U37
3
Was W37

12
Crisps Was S34
502
Was U34
1.5
Was W34 Crisps Was S34
502
Was U34
1.5
Was W34

9
Crisps Was S31
502
Was U31
2
Was W31 Crisps Was S31
502
Was U31
2
Was W31

4
Beer Was S26
200
Was U26
0.07
Was W26 Beer Was S26
200
Was U26
0.07
Was W26

2
Beer Was S24
200
Was U24
0.1
Was W24 Beer Was S24
200
Was U24
0.1
Was W24

6
Beer Was S28
210
Was U28
0.06
Was W28 Beer Was S28
210
Was U28
0.06
Was W28

5
beer Was S27
220
Was U27
0.2
Was W27 beer Was S27
220
Was U27
0.2
Was W27

Worksheet: Sorting

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

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 )

Results using coding above and same test range as previous coding

_____ Workbook: ProAktuellex8600x2SortTime6_8.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
H

I

J

K

W

X

Y

824

351

0.1

825

342

0.1

0

826

342

0

827

341

0.1

0

828

339

0.1

0

829

338

1

0

830

338

1

0

831

338

0.1

0.1

832

338

0.1

0.1

833

338

0.1

0

834

338

0.1

0

835

337

0.5

0.1

836

337

0.1

0.1

837

337

0.1

0

838

337

0

0.1

839

336

0.2

0

840

335

0.1

0

841

334

0

0.1

842

333

0.2

0

843

332

0.2

0

844

332

0.1

0.1

845

332

0.1

0

846

331

0.1

0.1

847

331

0.1

0.1

848

329

0.2

0

849

329

0.1

0

850

326

0.3

0

851

326

0.3

0

852

326

0.2

0

853

326

0.1

0

854

324

0.1

0.1

855

324

0.1

0

856

319

0.2

0.1

857

318

0.5

0.1

858

316

0.2

0.1

859

279

0.5

0.1

860

232

0.1

0

861

230

0.2

0

862

215

0

0

863

864

865

Worksheet: Sheet1

Time
Sub SimpleArraySort8( -- 3.4 secs
Sub ReorgBy3Criteria() ( Range.Sort ) -- .26 secs
Sub SimpleArraySort6( -- 1.2 secs

https://app.box.com/s/34mcb2pe4z9y8hhlb2h87xit4ksuiw9q " ProAktuellex8600x2SortTime6_8.xlsm "

Intermediate step coding for this post:
http://www.excelfox.com/forum/showth...ll=1#post11064
( Remember to include at top of module the global variable
Dim Rs() As Variant )

Intermediate routine

Code:

' Sub Call_Sub_Bubbles() ' data range info Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting") Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16") ' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8 Dim arrTS() As Variant ' array to be referred to in all recursion routines, initially the original data range Let arrTS() = RngToSort.Value Let Rs() = Evaluate("=Row(1:6)") ' ' Initial row indicies Call Bubbles(1, arrTS(), " 1 Asc 3 Asc 2 Asc ") ' Demo output Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrTS() End Sub ' Sub Bubbles(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc… If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it 'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level ' making an array from the " 3 4 5 6 " string is just for convenience later of getting the upper and lower row numbers Rem 1 Bubble sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' For first row indicie to last but one row indicie Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column For Clms = 1 To UBound(arsRef(), 2) Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp Next Clms '----------| for each column in the array at the two rows rOuter and rInner Else End If Next rInner ' ----------------------------------------------------------------------- Next rOuter ' ========================================================================================== End Sub

Intermediate step coding for this post:
http://www.excelfox.com/forum/showth...ll=1#post11075

Code:

Sub Call_Sub_BubblesIndexIdeaWay() ' Partially hard coded for ease of explanation ' data range info Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting") Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16") ' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8 Dim arrTS() As Variant ' This is somewhat redundant for this version and could be replaced by arrOrig() Let arrTS() = RngToSort.Value ' Index idea variables Let arrOrig() = arrTS() Let arrIndx() = arrTS() Let Cms() = Evaluate("=Column(A:D)") ' Convenient way to get Let Rs() = Evaluate("=Row(1:6)") ' Initial row indicies ' Add initial indicies Let RngToSort.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed Let RngToSort.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed ' Initial row indicies from full original range´of rows Dim strRows As String, Cnt As Long: Let strRows = " " For Cnt = 1 To 6 Let strRows = strRows & Rs(Cnt, 1) & " " Next Cnt ' we should have now strRows = " 1 2 3 4 5 6 " Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc 2 Asc ") ' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc ") ' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc ") ' Demo output Dim RngDemoOutput As Range: Set RngDemoOutput = WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count) ' Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrIndx() Let RngDemoOutput = arrIndx() Let RngDemoOutput.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed Let RngDemoOutput.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed End Sub ' Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc… If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it 'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level Rem 1 Bubble sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== ' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1 For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 'For rOuter = 1 To 5 ' For first run Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column For Clms = 1 To UBound(arsRef(), 2) Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp Next Clms '----------| for each column in the array at the two rows rOuter and rInner Dim TempRs As Long Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs Else End If Next rInner ' ----------------------------------------------------------------------- Next rOuter ' ========================================================================================== Rem 3 Preparation for possible recursion Call ' Catpains Blog Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below Let strRws = "" 'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1 For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates 'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces ) ' Now its time to organise a recursion run Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates Let strRws = "" ' ready to try for another set of duplicates Else End If ' we did not have more than one indicie in strRws so usually that's it for this loop End If '+++*** this would be end of loop for most cases ... but Oh Fuck 'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......| If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys) Else End If '... ................................................................| Next rOuter ' ************************************************************************** Debug.Print "Ending a copy, Copy level " & CopyNo & "" End Sub

Final modified coding for this post
http://www.excelfox.com/forum/showth...ll=1#post11075

Code:

Sub Call_Sub_BubblesIndexIdeaWay() ' Partially hard coded for ease of explanation ' data range info Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting") Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16") ' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8 Dim arrTS() As Variant ' This is somewhat redundant for this version and could be replaced by arrOrig() Let arrTS() = RngToSort.Value ' Index idea variables Let arrOrig() = arrTS() Let arrIndx() = arrTS() Let Cms() = Evaluate("=Column(A:D)") ' Convenient way to get Let Rs() = Evaluate("=Row(1:6)") ' Initial row indicies ' Add initial indicies Let RngToSort.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed Let RngToSort.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed ' Initial row indicies from full original range´of rows Dim strRows As String, Cnt As Long: Let strRows = " " For Cnt = 1 To 6 Let strRows = strRows & Rs(Cnt, 1) & " " Next Cnt ' we should have now strRows = " 1 2 3 4 5 6 " Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc 2 Asc ") ' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc ") ' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc ") ' Demo output Dim RngDemoOutput As Range: Set RngDemoOutput = WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count) ' Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrIndx() Let RngDemoOutput = arrIndx() Let RngDemoOutput.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed Let RngDemoOutput.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed ' ' Let RngDemoOutput.Offset(RngDemoOutput.Rows.Count, 0) = Application.Index(arrOrig(), Rs(), Cms()) End Sub ' Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc… If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it 'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level Rem 1 Bubble sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== ' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1 For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 'For rOuter = 1 To 5 ' For first run Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column For Clms = 1 To UBound(arsRef(), 2) Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp Next Clms '----------| for each column in the array at the two rows rOuter and rInner Dim TempRs As Long Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs Else End If Next rInner ' ----------------------------------------------------------------------- Next rOuter ' ==================End=Rem 1=============================================================== Rem 2 Let arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) Rem 3 Preparation for possible recursion Call ' Catpains Blog Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below Let strRws = "" 'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1 For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates 'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative If Trim(UCase(CStr(arrIndx(rOuter, Clm)))) = Trim(UCase(CStr(arrIndx(rOuter + 1, Clm)))) Then ' case in duplicate rows Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces ) ' Now its time to organise a recursion run Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates Let strRws = "" ' ready to try for another set of duplicates Else End If ' we did not have more than one indicie in strRws so usually that's it for this loop End If '+++*** this would be end of loop for most cases ... but Oh Fuck 'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......| If rOuter = UBound(arrIndx(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys) Else End If '... ................................................................| Next rOuter ' ************************************************************************** Debug.Print "Ending a copy, Copy level " & CopyNo & "" End Sub

_Row\^Col	H	J	X
824	351	0.1
825	342	0.1	0
826	342	0
827	341	0.1	0
828	339	0.1	0
829	338	1	0
830	338	1	0
831	338	0.1	0.1
832	338	0.1	0.1
833	338	0.1	0
834	338	0.1	0
835	337	0.5	0.1
836	337	0.1	0.1
837	337	0.1	0
838	337	0	0.1
839	336	0.2	0
840	335	0.1	0
841	334	0	0.1
842	333	0.2	0
843	332	0.2	0
844	332	0.1	0.1
845	332	0.1	0
846	331	0.1	0.1
847	331	0.1	0.1
848	329	0.2	0
849	329	0.1	0
850	326	0.3	0
851	326	0.3	0
852	326	0.2	0
853	326	0.1	0
854	324	0.1	0.1
855	324	0.1	0
856	319	0.2	0.1
857	318	0.5	0.1
858	316	0.2	0.1
859	279	0.5	0.1
860	232	0.1	0
861	230	0.2	0
862	215	0	0
863
864
865