Phil Turd

Option Explicit
'Private Sub Worksheet_Change(ByVal Target As Range)
'    If Range("A1") < "Filters" Then Exit Sub
'    If Target Is Nothing Then Exit Sub
'    If Target.Cells.Count > 1 Then Exit Sub
'    If Target.Column = 1 Then Filtering Target
'End Sub
'
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'    If Range("A1") < "Filters" Then Exit Sub
'    If Target Is Nothing Then Exit Sub
'    If Target.Column <> 1 Then Exit Sub
'    If Target.Cells.Count > 1 Then Exit Sub
'    If Target.Value = "" Then Exit Sub
'    Filtering Target
'End Sub
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 ' this string will have unique cell values only
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 = Left(UnEeks, Len(UnEeks) - 1) ' take off 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 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)
 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