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

**DocAElstein** · 02-03-2019, 08:06 PM

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