Rewrite Code as a Sub to work on Active Sheet

[user29383902]

Hi, Please I have this function, which is part of a a Sub macro in VBA, it replaces my old way of filtering, I want to use it as a standalone code for filtering in excel in any active sheet. By just pressing a shortcut like ctrl + w and it works on that sheet.

Function FilterX(ws As Worksheet) As Long

    Dim rng As Range, dict, c
    Dim lastrow As Long, n As Long
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' configure filter column, tolerance
    With dict
    '   .Add "L"
        .Add "M", 0 ' +/- 0
    '   .Add "N",
        .Add "O", 1 ' +/- 1
    '   .Add "P",
    '   .Add "Q",
        .Add "R", 2
    '   .Add "S",
    '   .Add "T",
        .Add "U", 1
    '   .Add "V",
        .Add "W", 1
    '   .Add "X",
    '   .Add "Y",
        .Add "Z", 2
    End With

    With ws
        ' remove filter
        If .FilterMode = True Then .ShowAllData
       
        ' apply fliter
        lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
        If lastrow < 3 Then
             FilterX = 0
             Exit Function
        End If
        
        Set rng = .Range("A1:AZ" & lastrow)
        'Debug.Print ws.Name, rng.Address
        
        ' apply filter to columns M, O, R, U, W, Z
        For Each c In dict.keys
            n = Cells(1, c).Column ' column number
            ' dict(c) is tolerance +/- on rows 2 value
            rng.AutoFilter Field:=n, Criteria1:=">=" & (.Cells(2, n) - dict(c)), _
                    Operator:=xlAnd, Criteria2:="<=" & (.Cells(2, c) + dict(c))
        Next
        
        ' return count
      On Error Resume Next 'skips error code when no cells are found
        FilterX = .Range("A3:A" & lastrow).SpecialCells(xlCellTypeVisible).Count
    End With
    
End Function

 

[user29383902]

Hi, Please I have this function, which is part of a a Sub macro in VBA, it replaces my old way of filtering, I want to use it as a standalone code for filtering in excel in any active sheet. By just pressing a shortcut like ctrl + w and it works on that sheet.

Function FilterX(ws As Worksheet) As Long

    Dim rng As Range, dict, c
    Dim lastrow As Long, n As Long
    Set dict = CreateObject("Scripting.Dictionary")
   
    ' configure filter column, tolerance
    With dict
    '   .Add "L"
        .Add "M", 0 ' +/- 0
    '   .Add "N",
        .Add "O", 1 ' +/- 1
    '   .Add "P",
    '   .Add "Q",
        .Add "R", 2
    '   .Add "S",
    '   .Add "T",
        .Add "U", 1
    '   .Add "V",
        .Add "W", 1
    '   .Add "X",
    '   .Add "Y",
        .Add "Z", 2
    End With

    With ws
        ' remove filter
        If .FilterMode = True Then .ShowAllData
      
        ' apply fliter
        lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
        If lastrow < 3 Then
             FilterX = 0
             Exit Function
        End If
       
        Set rng = .Range("A1:AZ" & lastrow)
        'Debug.Print ws.Name, rng.Address
       
        ' apply filter to columns M, O, R, U, W, Z
        For Each c In dict.keys
            n = Cells(1, c).Column ' column number
            ' dict(c) is tolerance +/- on rows 2 value
            rng.AutoFilter Field:=n, Criteria1:=">=" & (.Cells(2, n) - dict(c)), _
                    Operator:=xlAnd, Criteria2:="<=" & (.Cells(2, c) + dict(c))
        Next
       
        ' return count
      On Error Resume Next 'skips error code when no cells are found
        FilterX = .Range("A3:A" & lastrow).SpecialCells(xlCellTypeVisible).Count
    End With
   
End Function

Rewrite code as a Sub to work on activesheet

Please I have this function, which is part of code, it replaces my old way of filtering, I want to use it as a standalone code for filtering in excel in place of my old filtering code which can be...

stackoverflow.com

 

[Skyybot]

Here is your Funtion changed to a Subroutine. Follow instructions below.

Sub FilterX(ws As Worksheet) As Long

    Dim rng As Range, dict, c
    Dim lastrow As Long, n As Long
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' configure filter column, tolerance
    With dict
    '   .Add "L"
        .Add "M", 0 ' +/- 0
    '   .Add "N",
        .Add "O", 1 ' +/- 1
    '   .Add "P",
    '   .Add "Q",
        .Add "R", 2
    '   .Add "S",
    '   .Add "T",
        .Add "U", 1
    '   .Add "V",
        .Add "W", 1
    '   .Add "X",
    '   .Add "Y",
        .Add "Z", 2
    End With

    With ws
        ' remove filter
        If .FilterMode = True Then .ShowAllData
       
        ' apply fliter
        lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
        If lastrow < 3 Then
             FilterX = 0
             Exit Sub
        End If
        
        Set rng = .Range("A1:AZ" & lastrow)
        'Debug.Print ws.Name, rng.Address
        
        ' apply filter to columns M, O, R, U, W, Z
        For Each c In dict.keys
            n = Cells(1, c).Column ' column number
            ' dict(c) is tolerance +/- on rows 2 value
            rng.AutoFilter Field:=n, Criteria1:=">=" & (.Cells(2, n) - dict(c)), _
                    Operator:=xlAnd, Criteria2:="<=" & (.Cells(2, c) + dict(c))
        Next
        
        ' return count
      On Error Resume Next 'skips error code when no cells are found
        FilterX = .Range("A3:A" & lastrow).SpecialCells(xlCellTypeVisible).Count
    End With
    
End Sub

Click on Developer -> Click on Macros -> Find your Macro and highlight it. -> Click Options. Add your keyboard shortcut.