vendredi 28 décembre 2018

chekboxes for filtering data in VBA

I am relatively new to VBA and I would need your help with something. I have huge excel sheet with many columns and I would like to do a small tool which allows you to filter 4 different columns by checking the checkboxes containing the criteria. The first column I would like to filter has 12 criteria, the second has 33, the third 6 and the fourth 44. The user chooses some of the criteria for each filter and by clicking a button must be able to have the worksheet filtered and soma calculations are automatically done with the filtered data.

I have been able so far to do this just for one filter, but I can't seem to succeed when I try it for the other columns. Here is my code so far which works only for one filter. Is there any way I can adapt it in order to filter all the columns?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("B2:B13")) Is Nothing Then Exit Sub
    Target.Font.Name = "marlett"
If Target.Value <> "a" Then
    Target.Value = "a"
    Cancel = True
    Exit Sub
End If
If Target.Value = "a" Then
    Target.ClearContents
    Cancel = True
    Exit Sub

End If End Sub

Sub Filter_Me1()

Dim LR As Long
Dim cBox As Variant
Dim cel As Range
ReDim cBox(0)
With Sheets("S0002")
    .AutoFilterMode = False
    LR = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count),_
    SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each cel In Sheets("Sheet1").Range("B2:B13")
        If Not cel.Value = "" Then
            cBox(UBound(cBox)) = cel.Offset(0, -1).Value
            ReDim Preserve cBox(UBound(cBox) + 1)
        End If
    Next cel

    If IsError(Application.Match("*", (cBox), 0)) Then
        MsgBox "Nothing Selected"
        Exit Sub
    End If

    ReDim Preserve cBox(UBound(cBox) - 1)
    If Not .AutoFilterMode Then
        .Range("B2").AutoFilter
        .Range("A1:Z" & LR).AutoFilter Field:=2, Criteria1:=Array(cBox),_
         Operator:=xlFilterValues
    End If
End With

End Sub




Aucun commentaire:

Enregistrer un commentaire