Appendix Thread. App Index Rws() Clms() Majic code line Codings for other Threads, Tables etc.)

1 Attachment(s)

Full demo code to accompany last post:

Code:

Option Explicit Sub ThisShouldWork() Dim LastRow As Long, strEval As String Let LastRow = Cells(Rows.Count, "A").End(xlUp).Row Let strEval = Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow) Debug.Print strEval ' Hit Ctrl+g from the VB Editor to get the Immediate window up. 'IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,"")) 'This is the spreadsheet equivalent to Rick's Evaluate Range("B1:B" & LastRow).FormulaArray = "=" & strEval 'This gives a demo of the actual formulas that Excel VBA does Range("J5:J44").Value = "=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2,"" "",""""),"","","""")),IF(LEFT(A1,4)=""2018"",TRIM(A1&"" ""&A2),""""),IF(LEFT(A1,4)=""2018"",A1,""""))" ' Applying the fixed vector notation (Excel instructed to do that by no $s) will result in the same relative formula. Displayed will be the actual formula ( in the relative form, but that is not important) ' Final solution Rick : http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row?p=10888#post10888 Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow)) ' Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete ' This will mess up now due to my .FormulaArray as you can't delete bits of that End Sub ' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64 ' TRIM(A13" "&A14) ' IF( True , TRIM(A13" "&A14) , A13 ) ' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 ) ' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 ) ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") ) ' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))

and here it is again ... in "Ricks Table Code Tags" ( http://www.excelfox.com/forum/showth...0902#post10902 )

Code:

Option Explicit Sub ThisShouldWork() Dim LastRow As Long, strEval As String Let LastRow = Cells(Rows.Count, "A").End(xlUp).Row Let strEval = Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow) Debug.Print strEval ' Hit Ctrl+g from the VB Editor to get the Immediate window up. 'IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,"")) 'This is the spreadsheet equivalent to Rick's Evaluate Range("B1:B" & LastRow).FormulaArray = "=" & strEval 'This gives a demo of the actual formulas that Excel VBA does Range("J5:J44").Value = "=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2,"" "",""""),"","","""")),IF(LEFT(A1,4)=""2018"",TRIM(A1&"" ""&A2),""""),IF(LEFT(A1,4)=""2018"",A1,""""))" ' Applying the fixed vector notation (Excel instructed to do that by no $s) will result in the same relative formula. Displayed will be the actual formula ( in the relative form, but that is not important) ' Final solution Rick : http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row?p=10888#post10888 Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow)) ' Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete ' This will mess up now due to my .FormulaArray as you can't delete bits of that End Sub ' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64 ' TRIM(A13" "&A14) ' IF( True , TRIM(A13" "&A14) , A13 ) ' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 ) ' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 ) ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) ) ' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") ) ' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))

remember to scroll down first to find the scroll bar:
Scroll down to find Ricks Code bar.JPG : https://imgur.com/R3jgXek
Attachment 2136

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxUbeYSvsBH2Gianox4AaABAg. 9VYH-07VTyW9gJV5fDAZNe
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgyhQ73u0C3V4bEPhYB4AaABAg
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgzIElpI5OFExnUyrk14AaABAg. 9fsvd9zwZii9gMUka-NbIZ
https://www.youtube.com/watch?v=jdPeMPT98QU
https://www.youtube.com/watch?v=QdwDnUz96W0&lc=Ugx3syV3Bw6bxddVyBx4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg. 9fxrOrrvTln9g9wr8mv2CS
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg. 9fz3_oaiUeK9g96yGbAX4t
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg. 9fz3_oaiUeK9g7lhoX-ar5
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg. 9g9wJCunNRa9gJGhDZ4RI2
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg. 9f6hAjkC0ct9f8jleOui-u
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

1 Attachment(s)

XXNVCX:;YNXYN

Test Sort Routine

test post in support of this forum question
http://www.eileenslounge.com/viewtop...245488#p245485

Yellow is effectively the array fed to a sort routine.
Green is how that array looks like after running the sort routine

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

2

10

8

2

16

8

1

10

15

2

8

1

10

15

2

19

6

3

14

13

15

15

10

6

13

13

7

6

15

16

2

17

2

8

3

5

9

11

12

8

15

12

15

4

5

2

10

8

2

16

13

13

6

4

11

15

12

15

4

5

19

6

3

14

13

13

13

6

4

11

5

9

11

12

8

15

15

10

6

13

14

18

18

16

20

2

17

2

8

3

13

7

6

15

16

14

18

18

16

20

Worksheet: Sheet1

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

14

2

2.9986

17

1

1.9983

15

6

6.9985

19

1

1.9981

16

3

3.9984

20

1

1.998

17

1

1.9983

14

2

2.9986

18

2

2.9982

18

2

2.9982

19

1

1.9981

16

3

3.9984

20

1

1.998

15

6

6.9985

Worksheet: Sheet1

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

15

4

5

15

4

5

6

4

11

6

4

11

3

14

13

3

14

13

Worksheet: Sheet1

Test calling routine : ( called routines in next 2 posts )

Code:

Sub TestsStringArray() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31691&p=245488#p245488 Dim arrSel() As Variant Let arrSel() = Selection.Value Dim DumDom() As String: ReDim DumDom(0 To UBound(arrSel(), 1) - 1, 0 To UBound(arrSel(), 2) - 1) Dim rCnt As Long, cCnt As Long For rCnt = 0 To UBound(arrSel(), 1) - 1 For cCnt = 0 To UBound(arrSel(), 2) - 1 Let DumDom(rCnt, cCnt) = CStr(arrSel(rCnt + 1, cCnt + 1)) Next cCnt Next rCnt Call subSort2DArrayMultiElements(DumDom(), "1 2") ' Paste reorganised Array next to the selection Dim OutRange As Range: Set OutRange = Selection.Offset(0, Selection.Columns.Count) Let OutRange.Value = DumDom() End Sub

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

Sub

sub

d

Sub

func

h

Sub

func

h

Pub

pub

a

sub

pub

x

func

pub

m

func

pub

m

Pub

pub

p

func

pub

r

func

pub

r

Pub

pub

a

sub

pub

x

Pub

pub

p

Sub

sub

d

Worksheet: Sheet1

Test Sort Routine

SFNSAFSAFS

Routines called by test code , Sub TestsStringArray() , in last post:

Code:

Sub subSort2DArrayMultiElements( _ sparray() As String, _ spOrder As String _ ) ' Sort an array with TWO dimensions. ' Assume Sort on the 2nd Dimension ' so assumes it IS a 2 Dim array. ' Sort on more than one element. ' ' This uses a merge sort. ' The sort is set up as ascending and not case sensitive. ' ' Use ' subSortMultiElements Array, Order ' ' Ex Order = "1 4 0 3 2". ' Not all elements need be specified. ' Any delimiter may be used. ' Dim lnglArrayIndex As Long Dim lnglElements As Long Dim lnglEndArray As Long Dim lnglKey As Long Dim lnglLbound As Long Dim lnglM As Long Dim lnglN As Long Dim lnglNumSortKeys As Long Dim lnglO As Long Dim lnglP As Long Dim lnglPrevKeyCol As Long Dim lnglThisKeyCol As Long Dim lnglUBound As Long Dim lngSubArrayRows As Long Dim slKeyVal As String Dim slOrder As String Dim slOrderArray() As String Dim slSubArray() As String Dim slTopKeyVal As String lnglElements = UBound(sparray, 2) ' Make an Order Array. slOrder = spOrder ' Delimiter? ' Disappear the numbers. For lnglN = 0 To 9 slOrder = Replace(slOrder, CStr(lnglN), "") Next lnglN slOrder = Trim$(slOrder) ' Should only have the delimiter left. If Len(slOrder) = 0 Then slOrderArray = Split(spOrder, " ") Else slOrderArray = Split(spOrder, Mid$(slOrder, 1, 1)) End If lnglNumSortKeys = UBound(slOrderArray) + 1 ' Always Sort on the FIRST Key. lnglKey = CLng(slOrderArray(0)) subArrayMergeSort sparray, lnglKey ' Only one key? If lnglNumSortKeys = 1 Then Exit Sub End If ' Now go through the rest of the keys. ' We extract a series of arrays based on the KEY - 1. ' Any records to sort? If UBound(slOrderArray) > 0 Then For lnglN = 1 To lnglNumSortKeys - 1 ' Pick up the start Value from Key-1. lnglPrevKeyCol = slOrderArray(lnglN - 1) lnglThisKeyCol = slOrderArray(lnglN) slTopKeyVal = sparray(0, lnglPrevKeyCol) lnglLbound = 0 lnglUBound = UBound(sparray, 1) ' All the same. If sparray(lnglUBound, 0) = slTopKeyVal Then Exit For End If lnglArrayIndex = 0 lnglEndArray = UBound(sparray) Do lnglLbound = lnglArrayIndex slTopKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol) Do If lnglArrayIndex > lnglEndArray Then Exit Do End If slKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol) If slKeyVal <> slTopKeyVal Then lnglUBound = lnglArrayIndex - 1 Exit Do End If lnglArrayIndex = lnglArrayIndex + 1 Loop ' No need to sort if there's only ONE row. lngSubArrayRows = lnglUBound - lnglLbound If lngSubArrayRows > 1 Then ' Get those rows. ReDim slSubArray(lnglUBound - lnglLbound, lnglElements) lnglP = 0 For lnglM = lnglLbound To lnglUBound For lnglO = 0 To lnglElements slSubArray(lnglP, lnglO) = sparray(lnglM, lnglO) Next lnglO lnglP = lnglP + 1 Next lnglM ' Sort 'em. subArrayMergeSort slSubArray, lnglThisKeyCol ' Put 'em back. lnglP = 0 For lnglM = lnglLbound To lnglUBound For lnglO = 0 To lnglElements sparray(lnglM, lnglO) = slSubArray(lnglP, lnglO) Next lnglO lnglP = lnglP + 1 Next lnglM End If If lnglArrayIndex > lnglEndArray Then Exit Do End If Loop Next lnglN End If ' *********************************************************************** End Sub

KVKDLDKLJ

Code:

Sub subArrayMergeSort( _ ByRef vpArray As Variant, _ ByVal lngpElement As Long, _ Optional vpMirror As Variant, _ Optional ByVal lngpLeft As Long, _ Optional ByVal lngpRight As Long _ ) ' http://www.vbforums.com/showthread.php?t=473677 ' ' Recurse Merge Sort a TWO Dim array. ' ' Use... ' subMergeSort Array, Element ' ' lngpLeft and lngpRight are 0 at the start. ' ' Sorts on ONE element. ' Dim blnlRightIsLessThanLeft As Boolean Dim blnlLeftIsGreaterThanRight As Boolean Dim blnlIsNumeric As Boolean Dim lnglLeftStart As Long Dim lnglMid As Long Dim lnglOutputStart As Long Dim lnglRightStart As Long Dim vlSwap As Variant Dim lnglCElement As Long Dim lnglNumElements As Long Dim vlSwapRow() As Variant ' This is just to gain a tiiiny bit of speed. If IsNumeric(vpArray(0, lngpElement)) = True Then blnlIsNumeric = True Else blnlIsNumeric = False End If lnglNumElements = UBound(vpArray, 2) ReDim vlSwapRow(lnglNumElements) If lngpRight = 0 Then lngpLeft = LBound(vpArray, 1) lngpRight = UBound(vpArray, 1) ReDim vpMirror(lngpLeft To lngpRight, 0 To lnglNumElements) End If lnglMid = lngpRight - lngpLeft Select Case lnglMid Case 0 Case 1 ' Changed this to make it case insensitive. ' If vpArray(lngpLeft) > vpArray(lngpRight) Then If blnlIsNumeric = True Then If CLng(vpArray(lngpLeft, lngpElement)) _ > CLng(vpArray(lngpRight, lngpElement)) _ Then blnlLeftIsGreaterThanRight = True Else blnlLeftIsGreaterThanRight = False End If Else If StrComp( _ vpArray(lngpLeft, lngpElement), _ vpArray(lngpRight, lngpElement), _ vbTextCompare) _ = 1 _ Then blnlLeftIsGreaterThanRight = True Else blnlLeftIsGreaterThanRight = False End If End If If blnlLeftIsGreaterThanRight Then ' SWAP the whole row. For lnglCElement = 0 To lnglNumElements vlSwapRow(lnglCElement) = vpArray(lngpLeft, lnglCElement) Next lnglCElement For lnglCElement = 0 To lnglNumElements vpArray(lngpLeft, lnglCElement) = vpArray(lngpRight, lnglCElement) Next lnglCElement For lnglCElement = 0 To lnglNumElements vpArray(lngpRight, lnglCElement) = vlSwapRow(lnglCElement) Next lnglCElement ' vlSwap = vpArray(lngpLeft) ' vpArray(lngpLeft) = vpArray(lngpRight) ' vpArray(lngpRight) = vlSwap End If Case Else lnglMid = lnglMid \ 2 + lngpLeft subArrayMergeSort vpArray, lngpElement, vpMirror, lngpLeft, lnglMid subArrayMergeSort vpArray, lngpElement, vpMirror, lnglMid + 1, lngpRight ' Merge the resulting halves lnglLeftStart = lngpLeft ' start of first (left) half lnglRightStart = lnglMid + 1 ' start of second (right) half lnglOutputStart = lngpLeft ' start of output (mirror array) Do ' Changed this to make it case insensitive. ' If vpArray(lnglRightStart) < vpArray(lnglLeftStart) Then If blnlIsNumeric = True Then If CLng(vpArray(lnglRightStart, lngpElement)) _ < CLng(vpArray(lnglLeftStart, lngpElement)) _ Then blnlRightIsLessThanLeft = True Else blnlRightIsLessThanLeft = False End If Else If StrComp( _ vpArray(lnglRightStart, lngpElement), _ vpArray(lnglLeftStart, lngpElement), _ vbTextCompare) = _ -1 _ Then blnlRightIsLessThanLeft = True Else blnlRightIsLessThanLeft = False End If End If If blnlRightIsLessThanLeft Then ' COPY the complete row. ' vpMirror(lnglOutputStart) = vpArray(lnglRightStart) For lnglCElement = 0 To lnglNumElements vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement) Next lnglCElement lnglRightStart = lnglRightStart + 1 If lnglRightStart > lngpRight Then For lnglLeftStart = lnglLeftStart To lnglMid lnglOutputStart = lnglOutputStart + 1 ' COPY the whole row. ' vpMirror(lnglOutputStart) = vpArray(lnglLeftStart) For lnglCElement = 0 To lnglNumElements vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement) Next lnglCElement Next Exit Do End If Else ' COPY the complete row. ' vpMirror(lnglOutputStart) = vpArray(lnglLeftStart) For lnglCElement = 0 To lnglNumElements vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement) Next lnglCElement lnglLeftStart = lnglLeftStart + 1 If lnglLeftStart > lnglMid Then For lnglRightStart = lnglRightStart To lngpRight lnglOutputStart = lnglOutputStart + 1 ' COPY the complete row. ' vpMirror(lnglOutputStart) = vpArray(lnglRightStart) For lnglCElement = 0 To lnglNumElements vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement) Next lnglCElement Next Exit Do End If End If lnglOutputStart = lnglOutputStart + 1 Loop For lnglOutputStart = lngpLeft To lngpRight ' Swap the complete row. ' vpArray(lnglOutputStart) = vpMirror(lnglOutputStart) For lnglCElement = 0 To lnglNumElements vpArray(lnglOutputStart, lnglCElement) = vpMirror(lnglOutputStart, lnglCElement) Next lnglCElement Next End Select ' ********************************************************************* End Sub

VBA Filter for Columns instead of Rows. Phillip Filters

Coding for answer to this Thread
https://www.eileenslounge.com/viewto...p?f=30&t=31740

There are two main routines. They both are event routines reacting when the range A2 : A_ last data row is used.
A selection change routine will make the drop down list the first time that a cell is selected.
A value change routine, ( in the next post ) , makes a filtered range containing just columns having the selected value in that selected row

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
This makes a drop down list in column A when a cell is selected ( The range of ordered values needed to fill the drop down lists is made by this routine and it is placed in a worksheet with Name "DataSaladinValagationLists" )
This is briefly how this routine works:
It only does anything for a selection in the A column range.
It only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row
The range of data for that row is copied to the clipboard, excluding empty cells . The text held in the clipboard is retrieved.
A row in Excel is held in the clipboard as a string with a vbTab as separator, and this string also has a trailing vbCr & vbLf which we remove. http://www.eileenslounge.com/viewtop...=31395#p242941
A 1 Dimensional array is made from the retrieved string, strSptInDrpPlop() , and this is used to produce a simple string which only has unique cell values in it. This string is then used to replace the strSptInDrpPlop() contents with unique values
The unique values as well as a leading “-“ and trailing “Blank” are pasted out to the worksheet "DataSaladinValagationLists"

Code:

Sub test() Let Application.EnableEvents = True Call Worksheet_SelectionChange(Me.Range("A3")) Let Application.EnableEvents = True End Sub ' =DataSaladinValagationLists!A2:A3 Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' for initial making of list for drop down If IsArray(Target.Value) Then Exit Sub Rem 1 main worksheet data range info Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub ' only do anything for a selection in the A column range. If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub ' We already have made a drop down list - only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column Rem 2 make drop down list for this row ' 2a) get unique list of all values in row Let Application.EnableEvents = False Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy ' The range of data for that row is copied to the clipboard, excluding empty cells Let Application.EnableEvents = True Dim Dtaobj As Object ' Late Binding equivalent' If you declare a variable as Object, you are late binding it. http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/ Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/ http://www.eileenslounge.com/viewtopic.php?f=30&t=31547#p244124 Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText() Let strClip = Left(strClip, Len(strClip) - 2) ' Take off last vbCr & vbLf Application.CutCopyMode = False ' Clear clipboard, stop screen flicker Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare) ' a row in Excel is held as a string with a vbTab as seperator. The array made here may contain duplicated cell values Dim UnEeks As String: Let UnEeks = " " ' this string will have unique cell values only. I need an initial " " to make sure i can check for a number like " 7 " not just "7" as that might get confused with "27" Dim Cnt As Long For Cnt = 0 To UBound(strSptInDrpPlop()) If InStr(1, UnEeks, " " & Trim(strSptInDrpPlop(Cnt)) & " ", vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then ' I am not sure yet if the last check is needed. Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " " ' A similar string to the original retrieved from the clipboard strClip is made with the difference that the seperator is a space and we have no duplicated cell values Else End If Next Cnt 'Let UnEeks = Replace(UnEeks, vbTab, "", 1, -1, vbBinaryCompare) 'remove rogue vbtabs Let UnEeks = Mid(UnEeks, 2, Len(UnEeks) - 2) ' take off first and last " " ' Left(UnEeks, Len(UnEeks) - 3) ' take off " " & vbCr & vbLf 'Let UnEeks = "-" & " " & UnEeks & "Blanks" Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare) ' Replace the 1 Dimensional array values with only unique values ' 2b) sort list ( Bubble sort ) Dim Eye As Long, Jay As Long For Eye = 0 To UBound(strSptInDrpPlop()) - 1 'I want to take the next in the array, starting at the first. The process below should result in the smallest being put at this position, because I go through the rest , the inner Jay loop, and when ever i find something smaller i swap so the smalles comes here For Jay = Eye + 1 To UBound(strSptInDrpPlop()) ' I now go through comparing with each of the rest, the Jays If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then ' This is to overcome an extra problem that I have: I have strings, and VBA thinks that "6" is bigger than "35" but it thinks 6 is less than 35 If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) Then ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current Eye. By the next Eye, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next Eye Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp Else End If Else ' if we have text, then VBA still allows a comparison to sort - like B > A returns True If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp ' The element being compared with all the rest is bigger, so we swap it. The effect of this is that the smallest in the rest of the list being looked at, ( The Jay loop ) , will finally end up in the current Eye position. Else End If End If Next Jay Next Eye ' 2c) paste in values in DataSaladinValagationLists worksheet With Worksheets("DataSaladinValagationLists") Let .Range("A" & Target.Row & "").Value = "-" ' ' a leading "-" , Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop() ' unique values Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank" ' ' and trailing "Blank" End With ' 2d) Make dropdown list Target.Validation.Delete ' This is only necerssary if a drop down is already there Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & "" End Sub Sub testieCLDoWhile() Dim testieletter As String Let testieletter = CLDoWhile(3) ' should return "C" End Sub ' CLDoWhile is a Function to get column letter from column number Function CLDoWhile(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 CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile 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 ' '

Code:

Sub testsort() Dim df As String, d As String df = "df" Dim var If IsNumeric(df) Then var = CLng(df) Dim dg As String dg = "dg" MsgBox (dg > df) & " " & (dg > d) MsgBox "7" < "77" Dim seven As String, seventyseven As String Let seven = "7": Let seventyseven = "77" MsgBox seven < seventyseven If seven < seventyseven Then MsgBox "True" Dim arrStr(0 To 1) As String Let arrStr(0) = "7": Let arrStr(1) = "77" MsgBox arrStr(0) < arrStr(1) MsgBox "6" < "34" ' FALSE !!!!!!!!!!****************** End Sub

Filter for columns not for rows. Phill Turd Sorted

continued from last post.......

Private Sub Worksheet_Change(ByVal Target As Range)
This reacts to changes of values in column A, for example when selecting a value from the drop down list
Initially a "Blank" selection is changed to "" , and if a "-" was given then the original range is restored

The rest of this routine is very similar to the routine here https://www.eileenslounge.com/viewto...245286#p245218 The difference is that we need here now to determine one set of column indices to use in a code line like pseudo the following to get the required filtered range
Output() = Index ( Cells , allRowIndicies , someColumnIndicies)
( The previous example at that link required all columns and 2 sets of some rows for two outputs based on a column having a Y or not )

Code:

Sub testieCLDoWhile() Dim testieletter As String Let testieletter = CLDoWhile(3) ' should return "C" End Sub ' CLDoWhile is a Function to get column letter from column number Function CLDoWhile(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 CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile 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 ' ' Sub testieWksChange() Call Worksheet_Change(Me.Range("A2")) Let Application.EnableEvents = True ' Just incase it got turned off End Sub Private Sub Worksheet_Change(ByVal Target As Range) If IsArray(Target.Value) Then Exit Sub Rem 1 main worksheet data range info Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub ' only do anything for a selection in the A column range. Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column If Target.Value = "Blank" Then Let Application.EnableEvents = False: Let Target.Value = "": Let Application.EnableEvents = True Rem 2 test data range reset If Target.Value = "-" Then Let Application.EnableEvents = False Let Me.Range("C1", Me.Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value = Worksheets("Sheet1 (2)").Range("C1", Worksheets("Sheet1 (2)").Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value Let Application.EnableEvents = True Rem 3 Get indices( column numbers) for required columns, and all row indicies '3a) indices( column numbers) for required columns Else ' selected value is a unique value or "" for "Blank" Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value ' I dont need the first and third column, but it makes it easier to keep track of the correct columns indicie Dim Cnt As Long Dim strClms As String: Let strClms = "1 2 " ' For our required columns containing in this row the target selected value For Cnt = 3 To CntClms ' check columns from 3 for a match to the value in column 1 If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then ' This is indication of wanted column as it contains the value Let strClms = strClms & Cnt & " " Else End If Next Cnt Let strClms = Left(strClms, Len(strClms) - 1) ' Take off last " " Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare) Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1) ' for {1,2,7,9} = required columns For Cnt = 0 To UBound(clmsSpt()) Let Clms(Cnt + 1) = clmsSpt(Cnt) Next Cnt '3b) all data ro indicies Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")") ' = {1;2;3;4;5;6;7;8;9;.......... , CntItms} = required rows ( all rows are required ) Rem 4 Output filtered columns Dim arrOut() As Variant: Let arrOut() = Application.Index(Cells, Rws(), Clms()) Let Application.EnableEvents = False Me.Cells.ClearContents Let Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut() Let Application.EnableEvents = True End If End Sub Sub testsort() Dim df As String, d As String df = "df" Dim var If IsNumeric(df) Then var = CLng(df) Dim dg As String dg = "dg" MsgBox (dg > df) & " " & (dg > d) End Sub

Simplified coding

Simplified coding for yasser
https://eileenslounge.com/viewtopic....245769#p245769

Coding for worksheet code module for worksheet "Sheet1"

Code:

Option Explicit Public Sub Worksheet_SelectionChange(ByVal Target As Range) If IsArray(Target.Value) Then Exit Sub Rem 1 main worksheet data range info Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column Rem 2 make drop down list for this row Let Application.EnableEvents = False Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy Let Application.EnableEvents = True Dim Dtaobj As Object Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText() Let strClip = Left(strClip, Len(strClip) - 2) Application.CutCopyMode = False Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare) Dim UnEeks As String Dim Cnt As Long For Cnt = 0 To UBound(strSptInDrpPlop()) If InStr(1, UnEeks, Trim(strSptInDrpPlop(Cnt)), vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " " Else End If Next Cnt Let UnEeks = Left(UnEeks, Len(UnEeks) - 1) Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare) Dim Eye As Long, Jay As Long For Eye = 0 To UBound(strSptInDrpPlop()) - 1 For Jay = Eye + 1 To UBound(strSptInDrpPlop()) If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) Then Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp Else End If Else If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp Else End If End If Next Jay Next Eye With Worksheets("DataSaladinValagationLists") Let .Range("A" & Target.Row & "").Value = "-" Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop() Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank" End With Target.Validation.Delete Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & "" End Sub Function CLDoWhile(ByVal lclm As Long) As String Dim rest As Long Do Let CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile Let lclm = (lclm - (1)) \ 26 Loop While lclm > 0 End Function Public Sub Worksheet_Change(ByVal Target As Range) If IsArray(Target.Value) Then Exit Sub Rem 1 main worksheet data range info Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column If Target.Value = "Blank" Then Let Application.EnableEvents = False: Let Target.Value = "": Let Application.EnableEvents = True Rem 2 test data range reset If Target.Value = "-" Then Let Application.EnableEvents = False Let Me.Range("C1", Me.Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value = Worksheets("Sheet1 (2)").Range("C1", Worksheets("Sheet1 (2)").Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value Let Application.EnableEvents = True Rem 3 Get indices( column numbers) for required columns, and all row indicies Else Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value Dim Cnt As Long Dim strClms As String: Let strClms = "1 2 " For Cnt = 3 To CntClms If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then Let strClms = strClms & Cnt & " " Else End If Next Cnt Let strClms = Left(strClms, Len(strClms) - 1) Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare) Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1) For Cnt = 0 To UBound(clmsSpt()) Let Clms(Cnt + 1) = clmsSpt(Cnt) Next Cnt Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")") Rem 4 Output filtered columns Dim arrOut() As Variant: Let arrOut() = Application.Index(Cells, Rws(), Clms()) Let Application.EnableEvents = False Me.Cells.ClearContents Let Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut() Let Application.EnableEvents = True End If End Sub

Extra coding to go in normal code module

Code:

Option Explicit Sub Phillip_Filters() Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1") Dim Lr As Long: Let Lr = Ws1.Range("B" & Rows.Count & "").End(xlUp).Row Dim Cnt As Long Let Application.EnableEvents = False For Cnt = 2 To Lr Call Sheet1.Worksheet_SelectionChange(Ws1.Range("A" & Cnt & "")) Next Cnt Let Application.EnableEvents = True End Sub Sub ClearFilers() Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1") Dim Lr As Long: Let Lr = Ws1.Range("B" & Rows.Count & "").End(xlUp).Row Let Application.EnableEvents = False Ws1.Range("A2:A" & Lr & "").Validation.Delete Ws1.Range("A2:A" & Lr & "").ClearContents Let Application.EnableEvents = True Worksheets("DataSaladinValagationLists").Cells.ClearContents End Sub

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgxsozCmRd3RAmIPO5B4AaABAg. 9fxrOrrvTln9g9wr8mv2CS
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg. 9fz3_oaiUeK9g96yGbAX4t
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9g7pczEpcTz
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=UgyT1lo2YMUyZ50bLeR4AaABAg. 9fz3_oaiUeK9g7lhoX-ar5
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gD0AA-sfpl
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugx5d-LrmoMM_hsJK2N4AaABAg.9fyL20jCtOI9gECpsAVGbh
https://www.youtube.com/watch?v=U76ZRIzBhOA&lc=Ugw6zxOMtNCfmdllKQl4AaABAg. 9g9wJCunNRa9gJGhDZ4RI2
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugz-pow-E8FDG8gFZ4l4AaABAg.9f8Bng22e5d9f8hoJGZY-5
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxev2gQt7BKZ0WYMfh4AaABAg. 9f6hAjkC0ct9f8jleOui-u
https://www.youtube.com/watch?v=Sh1kZD7EVj0&lc=Ugxg9iT7MPWGBWruIzR4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

2	10	8	2	16	8	1	10	15	2
8	1	10	15	2	19	6	3	14	13
15	15	10	6	13	13	7	6	15	16
2	17	2	8	3	5	9	11	12	8
15	12	15	4	5	2	10	8	2	16
13	13	6	4	11	15	12	15	4	5
19	6	3	14	13	13	13	6	4	11
5	9	11	12	8	15	15	10	6	13
14	18	18	16	20	2	17	2	8	3
13	7	6	15	16	14	18	18	16	20

14	2	2.9986	17	1	1.9983
15	6	6.9985	19	1	1.9981
16	3	3.9984	20	1	1.998
17	1	1.9983	14	2	2.9986
18	2	2.9982	18	2	2.9982
19	1	1.9981	16	3	3.9984
20	1	1.998	15	6	6.9985

Sub	sub	d	Sub	func	h
Sub	func	h	Pub	pub	a
sub	pub	x	func	pub	m
func	pub	m	Pub	pub	p
func	pub	r	func	pub	r
Pub	pub	a	sub	pub	x
Pub	pub	p	Sub	sub	d

2	10	8	2	16	8	1	10	15	2
8	1	10	15	2	19	6	3	14	13
15	15	10	6	13	13	7	6	15	16
2	17	2	8	3	5	9	11	12	8
15	12	15	4	5	2	10	8	2	16
13	13	6	4	11	15	12	15	4	5
19	6	3	14	13	13	13	6	4	11
5	9	11	12	8	15	15	10	6	13
14	18	18	16	20	2	17	2	8	3
13	7	6	15	16	14	18	18	16	20

2	10	8	2	16	8	1	10	15	2
8	1	10	15	2	19	6	3	14	13
15	15	10	6	13	13	7	6	15	16
2	17	2	8	3	5	9	11	12	8
15	12	15	4	5	2	10	8	2	16
13	13	6	4	11	15	12	15	4	5
19	6	3	14	13	13	13	6	4	11
5	9	11	12	8	15	15	10	6	13
14	18	18	16	20	2	17	2	8	3
13	7	6	15	16	14	18	18	16	20