Filter for columns not for rows

[YasserKhalil]

Hello everyone
I have watched a video on that topic at this link
https://www.youtube.com/watch?v=ODh_PXOljPU" onclick="window.open(this.href);return false;
and I have written the code and changed a little so as to make it faster for the sub called "FillFilters" but it still takes some time
In standard module

Code: Select all

Sub FillFilters()
    Dim arr As Variant
    Dim oRange As Range
    Dim bDone As Boolean
    Dim sFilter As String
    Dim sTemp As String
    Dim i As Long
    Dim r As Long
    Dim c As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    If Range("A1") = "Filters" Then GoTo Skipper
    Sheet1.Range("A2").EntireColumn.Insert
    Set oRange = Sheet1.Range("A2").CurrentRegion
    
    With oRange
        .Cells.EntireColumn.Hidden = False
        .Cells(1, 1) = "Filters"
        For r = 2 To .Rows.Count
            For c = 3 To Columns.Count
                If WorksheetFunction.CountIf(Range(Cells(r, 3), Cells(r, c)), Cells(r, c)) = 1 Then
                    sFilter = sFilter & "," & Cells(r, c)
                End If
            Next c
            arr = Split(sFilter, ",")
            
            Do
                bDone = True
                For i = 1 To UBound(arr) - 1
                    If arr(i) > arr(i + 1) Then
                        bDone = False: sTemp = arr(i): arr(i) = arr(i + 1): arr(i + 1) = sTemp
                    End If
                Next i
            Loop While bDone = False
            
            sFilter = Join(arr, ",")
            With .Cells(r, 1).Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="-" & sFilter & ",Blanks"
                .InCellDropdown = True
            End With
            sFilter = ""
        Next r
        .Cells.EntireColumn.Hidden = False
    End With
    
Skipper:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Sub DeleteFilters()
    Application.ScreenUpdating = False
    If Range("A1") = "Filters" Then
        Cells.EntireColumn.Hidden = False
        Range("A1").EntireColumn.Delete
        Range("A1").Select
    End If
    Application.ScreenUpdating = True
End Sub

Sub Filtering(oFilter As Range)
    Dim oRange As Range
    Dim sCell As String
    Dim r As Long
    Dim c As Long
    Dim iRow As Long
    Dim iCount As Long

    Application.ScreenUpdating = False
    Set oRange = Sheet1.Range("A2").CurrentRegion
    sCell = oFilter.Value
    If sCell = "Filters" Then oRange.Cells.EntireColumn.Hidden = False: Exit Sub
    If sCell = "" Then oRange.Cells.EntireColumn.Hidden = False: Exit Sub
    If sCell = "-" Then oRange.Cells.EntireColumn.Hidden = False: Exit Sub
    If sCell = "Blanks" Then oRange.Cells.EntireColumn.Hidden = False: sCell = ""
    oRange.Cells.EntireColumn.Hidden = False
    iRow = oFilter.Row
    
    With oRange
        For c = 3 To .Columns.Count
            If .Cells(iRow, c) <> sCell Then
                .Cells(iRow, c).EntireColumn.Hidden = True
            Else
                iCount = iCount + 1
            End If
        Next c
    End With
    Application.ScreenUpdating = True
    
    MsgBox iCount & " Columns For Row " & iRow
End Sub

In worksheet module

Code: Select all

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

[HansV]

Thanks. I wouldn't use Worksheet_SelectionChange here, but that's a matter of taste.

[YasserKhalil]

But I mean the sub "FillFilters" .. when running it it takes some time but as for the other subs working fine

[HansV]

Did you meant that as a question? That wasn't clear from your first post.
FillFilters has to do a lot of work: for each row, create a list of unique values, and sort that list.
Does it work faster if you replace the lines

Code: Select all

            For c = 3 To Columns.Count
                If WorksheetFunction.CountIf(Range(Cells(r, 3), Cells(r, c)), Cells(r, c)) = 1 Then
                    sFilter = sFilter & "," & Cells(r, c)
                End If
            Next c
            arr = Split(sFilter, ",")

with

Code: Select all

        Dim d As Object
            Set d = CreateObject("Scripting.Dictionary")
            On Error Resume Next
            For c = 3 To Columns.Count
                d.Add Item:=Cells(r, c).Value, Key:=Cells(r, c).Value
            Next c
            On Error GoTo 0
            arr = d.Keys

[YasserKhalil]

Thanks a lot Mr. Hans
It is almost the same amount of time ..

[HansV]

Does the real worksheet you want to run this on have a large number of distinct values in a row?

[YasserKhalil]

No it has a large number of rows not columns
I think if we could use this trick of the unique values in just one row when in selection change instead of extracting all the unique values for all the rows .. this will be better .. What do you think of that?

[HansV]

The list is used to create a data validation dropdown in each of the cells of column A.
If you would create the dropdown in the SelectionChange event, the code would do this EACH TIME a cell in column A is selected. That is much less efficient.

[YasserKhalil]

Thanks a lot. So what's your opinion in that case? How can this FillFilters be faster?

[HansV]

When I tested it, the code that I suggested was slightly faster, but not by much. As long as the number of unique values per column is limited, I don't see a way for further improvement.

[YasserKhalil]

Thanks a lot Mr. Hans for your contributions

[Doc.AElstein]

Hello…..
I took a look at this, out of interest..
I watched that video ( Dr. Gerard Verschuuren : https://www.youtube.com/watch?v=ODh_PXOljPU" onclick="window.open(this.href);return false; ) a few times. I think I can see what is going on. But I don’t understand the explanations from Dr. Gerard Verschuuren .He seems to mostly just read through his code. I don’t see that he tries to actually explain the coding. So I cannot understand how it works. So I cannot suggest any changes, as I do not understand how the coding is working. I have no idea how that coding of his is working. I can’t understand it. So I cannot suggest any changes

But, If the object of the exercise is to filter by columns, then I am sure there are almost infinite ways to do it.

Here is an offering for me. I have no idea if it is quicker or slower. Probably quicker , mostly because I only make the drop down list the first time a column A is cell is selected**
I did not try to do anything along the lines of the Verschuuren offering, at least not intentionally, as I could not understand his coding. The only thing I did that was similar to the Verschuuren offering was a drop down list with an ordered list of all the values. I think it does something similar. But I am not sure because I do not fully understand his coding.
It is the first time ever that I did a drop down list. I thought it was about time, and so this seemed a chance to do it.
I just followed this video, https://support.office.com/en-us/articl ... 400a-b769-" onclick="window.open(this.href);return false; and recorded a macro as I did my first ever drop down list .
My data suggestion validation drop down lists are made once, the first time the row in column A is used **

Here is a brief coding description:
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 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/viewtopic. ... 95#p242941" onclick="window.open(this.href);return false;
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"

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/viewtopic ... 86#p245218" onclick="window.open(this.href);return false; 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 )

_.____________________________________________

I have rather a lot of 'comments on the coding which looks messy here, so better view the coding here: https://pastebin.com/axMh6MYc" onclick="window.open(this.href);return false;
excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10932#post10932
excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=10933#post10933




_._____________________________________________

In the uploaded test file, you have
_ the main data worksheet, “Sheet1” ,
_ a worksheet for the required ranges to fill the drop down lists, “DataSaladinValagationLists” , and
_ a full copy of the original data worksheet,” Sheet1 (2)” , which is needed to restore the original data sheet after a user selection of “-“ in any row in column A of the data range

I have not tested extensively, but at initial testing it seems to do something similar to the coding from Dr. Gerard Verschuuren


Alan

_._________________________________________
P.s. if you wanted to do a more direct comparison, then you could write a routine called something like, Sub Phillip_Filters() , and that could do a loop for Cnt = 2 To max data range row, and run like pseudo

Code: Select all

  For Cnt = 2 to max data range row
    Call Worksheet_SelectionChange(Range("A__Cnt")) 
  Next Cnt

Then code Sub Phillip_Filters() would fill all the filters in one go which would be a similar routine to the Sub FillFilters from Dr. Gerard Verschuuren

[YasserKhalil]

Thanks a lot Mr. Alan
In fact I have read each word you have written but I didn't get all the post. I have looked at the file and I am lost in the lines of the code
Please bear on me and just post the code without any comments and only the code that is related to the topic .. as I want not to be lost
I have tested the file and the code worked for a row then for another row I got an error at different lines
In addition to that I just need to deal with just one worksheet and not to rely on another sheet to do the task
The original file works fine for me ... the only problem for it is that it just take some time for the first time I run the sub called "FillFilters" but all other codes are running in perfect way

[Doc.AElstein]

Hi Yasser,
I was not intending to make a direct comparison with the original file and codes from Dr. Gerard Verschuuren from this youtube link https://www.youtube.com/watch?v=ODh_PXOljPU" onclick="window.open(this.href);return false;
I do not understand the coding from him.
_._____________

I have done a simplified file with just the two routines and one other function that is needed, and two extra routines described below

My routines do not hide columns. My routine pastes a new range. Because of this I need the extra worksheet to retrieve the original data when you choose the option of “-“

If the solution is no use for you then ignore it. Somebody else might find it useful.

Alan
_._________________________

Here are the two main routines and one required function with no comments. I cannot post them here because they will not fit in the post, even with no ‘comments
https://pastebin.com/zErf969m" onclick="window.open(this.href);return false;
Those three routines must go in the worksheet code module of Worksheet “Sheet1”

And here is an extra code that fills all the filters. This routine will be approximately equivalent to the routine FillFilters from Dr. Gerard Verschuuren

Code: Select all

 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

This following routine will clear the filters

Code: Select all

 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

All of the codes are in simplified form are in the enclosed file, “GerardVerschuurenSHG.xlsm”
Also here:
http://www.excelfox.com/forum/showthrea ... #post10934

[YasserKhalil]

In the file attached I select 14 from A3 then when selecting another cell (A5) I got an error '1004' (The action won't work on multiple selections at this line

Code: Select all

Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy

[Doc.AElstein]

I get that error as well. I think I know why. It will occur if you have only 1 data column showing and the column is empty at the row which you select. I did not envisage anyone wanting to make such a selection.

Instead of doing this,
select 14 from A3 then when selecting another cell (A5)
Do this instead
select 14 from A3 then , then select – from A3
Then You can select another cell with no problem I think.

I saw that error, but I did not think you would want to make another selection, if you only have 1 column shown and that row in that column was empty..

Try this for example, and it works
Choose 11 from cell A7
Now you can choose another cell. The error only occurs when you only have one column showing and the row is empty when you select that row from column A.


Also you will not get the error if you create all the filters first using Sub Phillip_Filters()

( I think possibly I am not too clear on what people want to do with filters )

It is probably best to run Sub Phillip_Filters() first. This will create all your filters first.
Sub Phillip_Filters() is similar to routine FillFilters from Dr. Gerard Verschuuren
Make sure all your data range is showing when you run Sub Phillip_Filters()
It is best to run Sub Phillip_Filters() at the beginning before you do anything else

Alan

[YasserKhalil]

Thanks a lot Mr. Alan for your great help

[Doc.AElstein]

The original file works fine for me ... the only problem for it is that it just take some time for the first time I run the sub called "FillFilters" but all other codes are running in perfect way

Here is a direct replacement for Sub FillFilters()


Instead of running
Sub FillFilters()
Run
Sub PhillsFilter()

For the original test data, I find that Sub PhillsFilter() is much faster than Sub FillFilters()

Code: Select all

 Sub PhillsFilter()
Rem 0 main worksheet data range info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
    If Ws1.Range("A1").Value = "Filters" Or Range("A1").Value = "Phill Turd" Then Exit Sub
 Let Application.EnableEvents = False
 Let Application.ScreenUpdating = False
Ws1.Range("A2").EntireColumn.Insert shift:=xlToRight
Dim CntItms As Long: Let CntItms = Ws1.Range("B" & Rows.Count & "").End(xlUp).Row
Dim CntClms As Long: Let CntClms = Ws1.Cells.Item(1, Columns.Count).End(xlToLeft).Column
Dim Orange As Range: Set Orange = Ws1.Range("A2", Ws1.Cells.Item(CntItms, CntClms))
 Let Orange.EntireColumn.Hidden = False
 Let Ws1.Range("A1").Value = "Phill Turd"
Rem 1 loop for rows
Dim Rws As Long
    For Rws = 2 To CntItms
    Rem 2 make drop down list for this row
     Let Application.EnableEvents = False
     Ws1.Range("C" & Rws & "", Ws1.Cells.Item(Rws, 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: Let UnEeks = " "
    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 = Mid(UnEeks, 2, Len(UnEeks) - 2)
     
     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
    Dim sFilter As String
     Let sFilter = "-," & Join(strSptInDrpPlop(), ",") & ",Blank"
    
    Ws1.Cells.Item(Rws, 1).Validation.Delete
    Ws1.Cells.Item(Rws, 1).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=sFilter
     Let sFilter = "": Let UnEeks = ""
    Next Rws
 Let Application.EnableEvents = True
 Let Application.ScreenUpdating = True
End Sub

It is not all done with Arrays. It might be a bit quicker with all Arrays, Possibily adding drop downs takes a long time. I don't have much exparience with drop downs.
Sub FillFilters() takes very long time for me even with small data rows.
Alan

_._____

The uploaded file below is your original File from the first post with only the addition of Sub PhillsFilter()

[YasserKhalil]

That's perfect Mr. Alan .. Thank you very very much
It is faster and perfect

Best and Kind Regards

[Doc.AElstein]

It is faster ....

Hi Yasser
I think it is less a case of my routine being fast, but more possibly likely that the routine from Dr. Gerard Verschuuren was unusually slow. I think possibly that there may be some strange problem with his routine. Even for small data it was very very slow.

I hope you noticed my typo… I Had Blank instead of Blanks here:
sFilter = "-," & Join(strSptInDrpPlop(), ",") & ",Blank"
it should be
sFilter = "-," & Join(strSptInDrpPlop(), ",") & ",Blanks"

Alan