Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

[DocAElstein]

This is required for the single Main routine which is posted in two parts in the last two posts


[Code]'2 Alan http://www.excelforum.com/showthread.php?t=1148621&page=3#post4441761
'5 Leith Ross http://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-visual-basic-applications-2.html#post4031122
'10 '....' "This is a recursive procedure to extract text from between an element's start tag and end tag and everything in between. Usually the Calling program will have passed a HTML code ( either from, for example, a .HTML File, a .Tex File, a .txt file, or from a returned such file after a request to a web page) into a Document Object Model. ( DOM ). This somehow organises things in a tree type structure , approximately as like you might see if you carefully indented the HTML code yourself, such that tag pairs were clear to see within tag pairs, each level down as it were. ( a "next level down" is often referred to as a "Child" ). The exact structure is less obvious, but in any case the DOM will have some ordered structure and every constitute part of the code is referred to as an Element. In a simple case most Elements have a start and stop pointed bracket. They are all nodes. Text is usually squeezed in between somewhere within a paired tag set, but is also referred to as a node.
'12 'I think a node is a point, usually a junction point in the tree type structure. Usually before the procedure is run a first time, an Element will have been obtained from the DOM and this is to be passed in the signature line of the procedure, as an Object. VBA then makes a Copy of the procedure and runs that with the given Element.
'15 'The macro will examine this Element Object brought in for a Text Node: If the element .NodeType is not 3 (a text node) then there are possibly child nodes ( Nodes "next down" in a Tree type listing ) that need to examined. The procedure then "Calls itself". In other words the first Copy stops at the Call Point. At the Call point another Copy of the procedure is made and runs in a loop for each child node.
'20 'The next Copy of the macro will again examine the element for a Text Node. If found (If element node type is 3), the text is concatenated with the ElemText String. If this is the ElemText string is empty then ElemText is set to this value. If not then this value is concatenated with any previous text and separated by a tilde character. This character can be used later to parse the text string into the individual strings from each element. The macro will exit the Sub at this point. When this happens, this copy of the macro is "removed from the call stack", in other words it Ends, and the last Copy continues from the Call point at which it was stopped.
Public Sub GetElemsText(ByRef Elem As Object, ByRef ElemText As String) 'It takes an Object, (variable Elem), a HTML Element, or a ( child ) node thereof. (Wiki says "An HTML element is an individual component of an HTML document or web page, once this has been parsed into the Document Object Model. (DOM). HTML is composed of a tree of HTML Elements and other nodes, such as text nodes." May be close to but not excactly what you se by carefully indenting down "Child" levels
'25 Dim strobjElem As String: Let strobjElem = TypeName(Elem)' http://www.excelforum.com/excel-programming-vba-macros/1149427-vba-determine-object-type-from-html-dom-object-put-type-in-string-variable-as-shown-in.html
65 Rem 1) Do we have an Element
70 If Elem Is Nothing Then GoTo LEndSub [color=darkgreen]'If the Object Elem is empty, or rather we are not given one, Then we End

[DocAElstein]

Part 2 of Main code.
This coding in this post should be copied diretly under the coding from the last post. Together they form a single routine, the Main routine

(The routine, Public Sub GetElemsText( ) , which is posted in the next post is also required for the Main routine to work )

Rem 3a) Directly
'
'
'     Simple text file print out using just result of  PageSrc   from '2a
     Debug.Print PageSrc ' unfortunately you will unlikely be able to view the whole String as it appears too big. Also pasting to a cell will not make it all visible. However if after pasting the .value from the cell is put in a string and that used in place of Pagesrc in the creation of the DOM it does work, so indicating that the data is there, but just not possible for us to "see".
    Dim strTextFile As String: Let strTextFile = ThisWorkbook.Path & "\Updates\strTextFile.txt"
    Dim HghWyNo2 As Long: Let HghWyNo2 = FreeFile(RangeNumber:=1)
     Open strTextFile For Binary As #HghWyNo2
     Put #HghWyNo2, 1, PageSrc '  Use Put to write the whole array at once  http://www.vb-helper.com/howto_read_write_binary_file.html   https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/put-statement
     Close HghWyNo2
'
'
'
'Application.Cursor = xlDefault' Restore the cursor to normal.
Rem 3b) Large Object from main made OOP type model object, (HTMLdoc)    ( Rem 3b)(i) )          ' Dim Head As Object
'Dim Head As IHTMLElementCollection 'requires Early Binding. getElementsBy___ returns a NodeList which is an interface to the DispHTMLElementCollection which is an internal class that you're not supposed to see/use. It does implement the IHTMLElementCollection though so you can use that.
Dim Head As Object ' Unusually this Large main Object is Dim ed as an Object, ..as you find you cannot Dim it as what its TypeName( ) returns ( or as displayed in the Watch Window ), “DispHTMLElementCollection“ .
 Set Head = HTMLdoc.getElementsByTagName("Table") 'This Object is a massive thing again with loads in, but this time it would appear to be the things "tagged" with < table >  < /table > which look like the headings of each table I am interested in
Rem 4)(Rem 3b)(ii)) Often we would loop here for each "Table" but in our example we only have one
'Dim oTable  As THMLTable ' If we had Early binding, then this would work, because omehow  Head  has been recognised as a table   oTable as HTMLTable.JPG : https://imgur.com/R309JjC , and for ..._
Dim oTable  As Object ' _... this table we have typically present in the object  ' HTML TableRow count , "column" Count for final Table will need to be calculated, "HTML Cell" count in Entire Table
Dim C As Long, r As Long 'Indicies for getting appropriate Row and HTMLTableCell
'Dim n As Long ' Not needed if only one table so only "1 Loop"
'4b)=== main working would be Outer loop for each Table in many similar routines==============Building Array from HTML Table
'For n = 0 To Head.Length - 1 ' We only have one table so don't need to loop. The word Length in HTML things is often similar to what Count is in many VBA objects
 Set oTable = Head(0) ' Somehow  Head  has been recognised as a table   oTable as HTMLTable.JPG : https://imgur.com/R309JjC
'4b(i) Fill variable for dimensions variable for each, one on our case, Main loop
Dim rowCnt As Long: Let rowCnt = oTable.Rows.Length  ' "length" / number of rows in this table
Dim colCt As Long:  Let colCt = oTable.Cells.Length 'In this object the cells "length" would appear to be the number / count of cells in the entire table
Dim colCnt As Long: Let colCnt = Application.WorksheetFunction.RoundUp((colCt / oTable.Rows.Length), 0) ' 'This rounds up to the nearest avarage row width, that is to say column number in a row  '   I thought this did ? colCt \ oTable.Rows.Length
Dim Data() As String 'Array with string element used for output table. Fixed (static) String type for Text.
     ReDim Data(0 To rowCnt - 1, 0 To colCnt - 1) 'Output Array, reDimed to table being looked at. ( Hopefully always same column number, might want to hard Code to  rowCnt, 11 columns . Because I am using "base" of indicie to start at 0 then I go from 0 to one less than the Count(Length)
'4b(ii)  Looping through rows to build output array-----------|
'---Inner loop does at each row, ....
        For r = 0 To rowCnt - 1 'Going along the HTML Table rows exactly as pike ' https://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-vba.html#post4026613
'--- .... 'go through each Cell( "column" )  in that row.
            For C = 0 To colCnt - 1 'Going along the HTML Table Cells (columns) exactly the same as pike
'4b(ii)a Build Output Array
             Call GetElemsText(oTable.Rows(r).Cells(C), Data(r, C))   'Data(r, c) = oTable.Rows(r).Cells(c).innerText '  pike, kyle type alternative to calling sub
'4b(ii)b "post processing last column of unified units. ' Probably bad place to put this, other than Speed.. checking / changing units
'                If C = .....
'
'                Else
'                End If
            Next C
'--- .... 'go to next "Cell" in that table row (next Column we "see" in the table row)
        Next r
'---  'Go to next row in this table----------------------------|
'4b(ii)c  Output from Array
 Let Range("A1").Resize(UBound(Data(), 1) + 1, UBound(Data(), 2) + 1).Value = Data()
 Columns("A:Z").AutoFit
'Next n 'go back with a new item, n in large collection Object(item) to get next object within and start checking that one out.
'Go to the next table====
Set HTMLdoc = Nothing ' If done then  when we no longer need it
End Sub '

[DocAElstein]

Post to support this Thread:
http://www.excelfox.com/forum/showth...0888#post10888
_1) This part of Rick’s solution
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))

I have seen something similar to this before, but it is lost to mankind hidden down in the comment section of a Blog site, Allen Wyatt’s I think…… so its nice that something like this has seen the light of day here…

If I am not mistaken, this non-looping macro should also work...

Sub ThisShouldWork()
 Dim LastRow As Long
 LastRow = Cells(Rows.Count, "A").End(xlUp).Row
 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
End Sub

To help simplify the explanation, lets take it that we know our range , ( http://www.excelfox.com/forum/showth...-row#post10870 ) so we have LastRow = 40
Two arbitrarily chosen characters, @ and # , are being used to enter into the main formula the LastRow or LastRow +1
Pseudo like we are doing this sort of thing
Replace( “A#” , “#” , “40” ) in order to end up with like “A40”
By inspection of the main formula, and with a bit of eye straining you can probably see where you replace those @ and # with 40 and 41
Just to be sure , running this will get you a nice copy able version of the main formula in the immediate window , ( after running you Hit Ctrl+g from the VB Editor to get the immediate window up):

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)
 'Range("B1:B" & LastRow).FormulaArray = "=" & strEval
 Debug.Print strEval  '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,""))

That did work.JPG : https://imgur.com/01sQ91X

_._______________________-
Before moving on a useful note: It is always useful when developing these formulas to view the string in the Immediate window: That can help with tricky syntaxes : The formula seen on the Immediate window must look like a formula in the same syntax as you would manually type it into a cell. So you can see immediately if you get something wrong , such as an error in the finally seen quotes.
_.__________________________
So we have our final formula:
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,""))
The way these formulas appear to work within the Evaluate(“ “) appears to be tapping into an along the columns , down a row, then along the columns… type updating raster to update a worksheet. The available output then seems to be that which encompasses the deepest and widest ranges. It is a ,little bit more complicated than that ( http://www.excelfox.com/forum/showth...on-and-VLookUp ) , but for our formula we have nice regular equally sized ranges so we are expecting an output of 1 “wide” and 40 “deep”. So for analysis purposes, we can reduce the formula to 40 similar ones.

Lets take the example of the formula for the 13th “down” output ..
IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13&" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))
Clearly we need to look at this data to see what that formula will do, because this data is used in that formula
_____ Workbook: NormanOrrinRickFilter.xlsm ( Using Excel 2007 32 bit )

Row\Col	A
13	2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah,
14	10006098, 15392.64

Worksheet: Rick

We have some nested IFs , and I find it is always a good idea to break those down so that we can start doing them as Excel or VBA would do them, that is to say from the middle working outwards. I tend to do this in a text editor with a horizontal scroll bar, or in the VB Editor window
Formula in VB Editor as comment.JPG : https://imgur.com/3cjyqSR

So this is what we have, broken down into the constituent IF sections.
( It may be better to copy this and view in your VB Editor in a wide window. I am working from the bottom , upwards )

' 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,""))

Examining the first line , I can evaluate the two innermost IFs and reduce the formula to

' 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 ,"" ) ) 

I will now evaluate some of those SUBSTITUTEs
( Excel Substitute, seems to work similarly to VBA Replace )

' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 ) 
' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 ) 

( I am guessing that 0+ will ensure that a number will not be mistaken as a text )

For the case of the 13th “down” formula the final steps in the evaluation go as follows

' 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 )

Here are all the steps together again

' 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,""))

The final result will appear in the 13th down position of the 40 “deep” array final results for the entire formula evaluation.
If you can view that last summary on a wide window, it should be able to see how the differing results for the other 39 results are achieved from the formula
Just to make clear once again what seems to go on in these sort of Evaluate formulas, in the next post is a table showing the actual Evaluateions done by VBA

_._____

_2 The final part of Rick’s solution is
Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete
This uses the VBA SpecialCells Method to get at the cells with nothing in them. Those are then deleted
Explanation:
VBA SpecialCells Method ( https://www.mrexcel.com/forum/excel-...onditions.html , https://docs.microsoft.com/en-us/off...e.specialcells ) returns you a range object ( that range object must not be contiguous ( connected ) cells ) consisting of those cells meeting a specific characteristic. We can choose from a number of characteristics. Here we choose xlBlanks , which refers to the characteristic of the cell being empty. So, if we applied that .SpecialCells(xlBlanks) to this range:.._

Row\Col	B
9
10
11	2018, 1, 90515, 10024515, G9, SBlabla (HQ), CHE, BLABLA, blabla, 10012098, 12003.5
12	2018, 1, 90629, 10022334, P3, BLABLA blabla (blablabla), CHE, BLABLA,blabla, 10033609, 13941.72
13	2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
14
15	2018, 1, 90765, 10012123, P4, Ch of Blabla(Blabla of Blabla), CHE, BLA-BLA,Bla Blabla, 10005678, 16231.7

_ … then the returned range from that would be Range(“B9:B10,B14”).
If we then apply .Delete to that range then those cells are removed. If you remove a cell via .Delete then initially there is a real hole, like a “black hole” that can’t really exist in a spreadsheet. So Excel might explode or implode, or you would be sucked into that hole , never to return!!! To prevent that happening, Excel shifts all cells to close that hole, ( and adds a new virgin cell at the bottom or right side to fill the indent there caused by the shift. The default Delete option for the direction of that shift is in our case upwards. Hence after applying the .Delete after applying .SpecialCells(xlBlanks) to the above range, ( pseudo like doing something this Range(“B9:B10,B14”).Delete(Shift:=xlUp) ) we will be left with

Row\Col	B
9	2018, 1, 90515, 10024515, G9, SBlabla (HQ), CHE, BLABLA, blabla, 10012098, 12003.5
10	2018, 1, 90629, 10022334, P3, BLABLA blabla (blablabla), CHE, BLABLA,blabla, 10033609, 13941.72
11	2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
12	2018, 1, 90765, 10012123, P4, Ch of Blabla(Blabla of Blabla), CHE, BLA-BLA,Bla Blabla, 10005678, 16231.7
13
14

What has happened there is the following: Those empty cells ( which were yellow ) have been removed. Other cells have been shifted up to fill up the “holes” created by the removal
( Rick’s code line actually deletes the EntireRow of that row on which the empty cells are found )

_.______________________________________________

Just to make clear once again what seems to go on in these sort of Evaluate formulas, in the next post is a table showing the actual Evaluateions done by VBA

[DocAElstein]

Full demo code to accompany last post:

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 )

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
Scroll down to find Ricks Code bar.JPG

[DocAElstein]

Continued from last post

In a range evaluate type code line like the one we are considering, Excel VBA seems to do the following ( simplified ) ( refs *** )

Excel will have an output "window" ( this could be considered as an output table or output array ). The dimensions of this will be that rectangle that allows all used ranges in the formula to be fitted in,
There are some complicated ways in which Excel handles the situation of ranges of varying size, ( http://www.excelfox.com/forum/showth...on-and-VLookUp ) but for a simpler case of all ranges having the same size, ( in terms of "width" and "depth" ) , as we have, Excel VBA will "expand" its "output window" to this sort of thing:

Excel VBA will do its normal "along the columns, down a row, along the columns…" type thing, in any "Evaluation run". In our case this will mean that it does an evaluation at each row, going down the rows. This is what Excel VBA does in order to fill that last window of cells, ( I am just showing the first 7 of 40 similar formulas as the full list is to big to fit in a forum post )

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2," ",""),",","")),IF(LEFT(A1,4)="2018",TRIM(A1&" "&A2),""),IF(LEFT(A1,4)="2018",A1,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A3," ",""),",","")),IF(LEFT(A2,4)="2018",TRIM(A2&" "&A3),""),IF(LEFT(A2,4)="2018",A2,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A4," ",""),",","")),IF(LEFT(A3,4)="2018",TRIM(A3&" "&A4),""),IF(LEFT(A3,4)="2018",A3,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A5," ",""),",","")),IF(LEFT(A4,4)="2018",TRIM(A4&" "&A5),""),IF(LEFT(A4,4)="2018",A4,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A6," ",""),",","")),IF(LEFT(A5,4)="2018",TRIM(A5&" "&A6),""),IF(LEFT(A5,4)="2018",A5,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A7," ",""),",","")),IF(LEFT(A6,4)="2018",TRIM(A6&" "&A7),""),IF(LEFT(A6,4)="2018",A6,""))

=IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A8," ",""),",","")),IF(LEFT(A7,4)="2018",TRIM(A7&" "&A8),""),IF(LEFT(A7,4)="2018",A7,""))

Excel VBA will effectively make 40 formulas and place in the "output window" the result of the evaluation of those formulas
The full demo code in the next post includes a code line to put in all 40 formulas in an arbitrary 40 "deep" x 1 "wide" range ("J5:J44")






refs ***
http://www.excelfox.com/forum/showth...age3#post10201

[DocAElstein]

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 )

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

[DocAElstein]

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

[DocAElstein]

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

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

[DocAElstein]

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"

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
'
'

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

[DocAElstein]

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 )

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