P2P Cloud DVR remote Access via a (remote) PC Using Guarding Vision PC Client Software

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

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

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

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

---

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg
https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg. 9irLgSdeU3r9itU7zdnWHw
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htJ6TpIOXR
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htOKs4jh3M
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

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

---

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

---

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

---

Positioning of procedure separation Line in the Visual Basic Development Environment

These are some notes based on a discussion here.. http://www.eileenslounge.com/viewtopic.php?f=30&t=31756
Lisa Green had noticed something strange in how VBA divides procedures.....

It appears that in VBA, that is to say in the Visual Basic Development Environment Window , ( that window seen by hitting Alt+F11 from a spreadsheet ) , the convention has been set to separate procedures by a line extending across the code pane Window.
We see these as appearing as a series of underscores, __________________ , extending across the Visual Basic Development Environment Window

Code:

---

End Sub  '  The dividing line appears to us as a line of underscores ____

---

---

---

Usually, if we did write exactly this ' The dividing line appears to us as a line of underscores ____ ' , on that terminating line above , then we would not see those underscores, ____ , as they get hidden in the terminating line:
Hidden_____InDividingLine.JPG : https://imgur.com/7DyP9Om
Attachment 2142
The above screenshot shows the simplest case of routines with no “space” in between. In that simple case, the position of the dividing line is as expected in between the procedures. The situation is a bit more complicated if there is a separation in between procedures….

Effect of blank lines ( or ‘commented lines ) In Between
Between procedures we may add blank lines or ' comment lines. If this is done, it appears that the convention has been set to place the line somewhere between the procedures in this blank/ ‘comment range, and the lines above the line “belong” to the procedure above, that is to say the last or preeceding procedure, and the lines below the line “belong” to the procedure below, that is to say the next procedure, http://www.eileenslounge.com/viewtop...=31756#p245845

The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________

Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _

Line continuation / Break points : single underscores _
We note in passing , that single underscores are used in coding generally to allow us to divide a single line of code into several lines for ease of reading. For example:

Code:

---

' http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row-*SOLVED*?p=10891#post10891
Sub LineContunuationUnderscores() ' https://docs.microsoft.com/en-us/dotnet/visual-basic/programming-guide/program-structure/how-to-break-and-combine-statements-in-code
  Dim LastRow As Long
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
 
' Without line breaks
  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))
 
' With Line breaks
  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))
'  This is _
    acceptable in _
or out of a  procedure
End Sub
'  This is _
    acceptable in _
or out of a  procedure__________________________________________________________________________________________________________________________________________________________________________________________________________________________________________________________

---

Further, we note that the line continuation , sometimes called a line break, _ , also applies to comments whether in a procedure or between procedures:
' This is _
acceptable in _
or out of a procedure

_._________

Determining position of horizontal line dividing procedures when blank or comment lines are between procedures
Sir Narios .
The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________
Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _
There appear to be 3 scenarios to consider in order to place the line somewhere in between, ( 4 if you consider the simple case of all lines containing comments or all lines being blank )

Scenario 0
' _(0)
If all lines are blank, or all lines are full with comments ( which exclude line continuations )
No single underscores in any line
The break is immediately after the Last/ upper procedure. (This is the same as the case for no separation between routines )
Scenario 0 .JPG : https://imgur.com/pA4grFL
Attachment 2143

Code:

---

Sub Scenario_0()
' _(0)
End Sub___________________________________________________________________________________________________________________________________________________________________________________________________________


 Sub senario_0()
' _(0)
End Sub_____________________________________________________________________________________________________________________________________________________________________________________________________________________
'
'
'
Sub surnario_0()
' _(0)
End Sub_____________________________________________________________________________________________________________________________________________________________________________________________________________________________

---

Scenario 1
' _(i) Attachment 2141 SirNario_1.JPG . https://imgur.com/zmr2up2
If no line continuations are present and there is a one or more blank lines, then the line before the first blank line down from the upper routine is taken as the break point.
No single underscores in any line

Code:

---

Sub Senario_1()
' _(i)
End Sub
'
'________________________________________________________________________________________________________________________________________________________________________________________________________________________________

Sub surnaria_1()
' _(i)
End Sub
'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________

''

'
Sub Sirnario_1()
' _(i)
End Sub_______________________________________________________________________________________________________________________________________________________________________________________________________________


'
'
Sub snaria_1()
' _(i)
End Sub

---

Scenario 2
' _(ii) Attachment 2144 SirNario_2.JPG : https://imgur.com/D2LqloV
If there are one or more line continuations present then the break point will be placed at the first blank line down after the last line after the line continuation … unless scenario (iii)

Code:

---

Sub Scnari_2()
' _(ii)
End Sub

''
'
' _

'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________

'

Sub Sernario_2()
' _(ii)
End Sub
'
'
' _
'
'___________________________________________________________________________________________________________________________________________________________________________________________________________________________________

'
Sub Sirnarnio_2()
' _(ii)
End Sub

---

Scenario 3
' _ (iii) Attachment 2146 SirNario_3.JPG : https://imgur.com/ho56uBN
There are no blank lines after the first line looking down after the last line continuation looking down, or after the first line looking down after the last line continuation looking down all lines contain comments . In this case, the break is at the line after the line on which the line continuation is on.

Code:

---

Sub scenario_3()
' _(iii)
End Sub
''
' _
____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
'
'
Sub SirNario_3()
' _(iii)
End Sub

'
' _
'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
'
'
Sub snuaro_3()
' _(iii)
End Sub
'

'
' _
____________________________________________________________________________________________________________________________________________________________________________________________________________________________________





Sub SirNario_3()

End Sub
'
' _
'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________



Sub SurNario_3()

End Sub

---

Rotines for this excelfox Thread
http://www.excelfox.com/forum/showth...0943#post10943

This is part 1 of the coding. The second part is in the next post. The second part must be copied directly under this part in the same code module

Code:

---

Option Explicit          '
Option Compare Binary    '    https://docs.microsoft.com/de-de/dotnet/visual-basic/language-reference/statements/option-compare-statement

Sub TestWtchaGot()
' In the practice we would likely have our string obtained from some method and would have it held in some string variable
Dim strTest As String  '                            "Pointer" to a "Blue Print" (or Form, Questionnaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular “Value”, or (“Values” for Objects). There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructions will tell how to do this. Theoretically a special value vbNullString is set to aid in quick checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
 Let strTest = Chr(1) & "Hi" & vbCrLf & vbTab & """u."""
 Call WtchaGot(strIn:=strTest)
' Call WtchaGot(Chr(1) & "Hi" & vbCrLf & vbTab & """u.""")
End Sub

Sub WtchaGot(ByVal strIn As String)
Rem 1  ' Output "sheet hardcopies"
'1a) Worksheets    'Make a Temporary Sheet, if not already there, in Current Active Workbook, for a simple list of all characters
    If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then '  ( the '  are not important here, but iin general allow for a space in the worksheet name like  "Wotcha Got In String"
    Dim Wb As Workbook '                                  ' ' Dim:  ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense )                    '
    Set Wb = ActiveWorkbook '  '                            Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want...        Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed.      http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191                                '
    Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
    Dim ws As Worksheet '
    Set ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want...    Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed.      http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191            ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed.      http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
    ws.Activate: ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
    Let ws.Name = "WotchaGotInString"
    Else ' The worksheet is already there , so I just need to set my variable to point to it
    Set ws = ThisWorkbook.Worksheets("WotchaGotInString")
    End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn)  '            ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in.  '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. )      https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header  Array for the output 2 column list.  The type is known and the size,  but I must use this ReDim  method simply because the dim statement  Dim( , )  is complie time thing and will only take actual numbers
 Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is  " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 20)
Rem 2  String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
    For Cnt = 1 To myLenf ' ===Main Loop========================================================================
    ' Character analysis: Get at each character
    Dim Caracter As Variant ' String is probably OK.
    Let Caracter = Mid(strIn, Cnt, 1) ' '    the character in strIn at position from the left of length 1
    '2a) The character added to a single  WotchaGot  long character string to look at and possibly use in coding
    Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line  required to build the full string of the complete character string
        '2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
        If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
        Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of  "a" & "1" & "2" & "3" &      I would phsically need to write in code  like  strVar = "a" & "1" & "2" & "3"  -  i could of course also write  = "a123"  but the point of this routine is to help me pick out each individual element
        Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf  vbTab
        Select Case Caracter ' 2a)(ii)_1
          Case " "
          Let WotchaGot = WotchaGot & """" & " " & """" & " & "
          Case "!"
          Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
          Case "$"
          Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
          Case "%"
          Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
          Case "~"
          Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
          Case "&"
          Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
          Case "("
          Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
          Case ")"
          Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
          Case "/"
          Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
          Case "\"
          Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
          Case "="
          Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
          Case "?"
          Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
          Case "'"
          Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
          Case "+"
          Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
          Case "-"
          Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
          Case "_"
          Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
          Case "."
          Let WotchaGot = WotchaGot & """" & "." & """" & " & "
'          Case " "
'          Let WotchaGot = WotchaGot & """" & " " & """" & " & "
'          Case " "
'          Let WotchaGot = WotchaGot & """" & " " & """" & " & "
'          Case " "
'          Let WotchaGot = WotchaGot & """" & " " & """" & " & "
'          Case " "
'          Let WotchaGot = WotchaGot & """" & " " & """" & " & "
'          Case " "
'          Let WotchaGot = WotchaGot & """" & " " & """" & " & "
'          Case " "
'          Let WotchaGot = WotchaGot & """" & " " & """" & " & "

---