Skip to main content
deleted 527 characters in body
Source Link
CDP1802
  • 15.7k
  • 2
  • 9
  • 18
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
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
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
Source Link

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 found here

Excel VBA Loop Copy/paste, autofilter, return value and loop

I want to be able to use it in any active sheet just like I used the old one. By just pressing a shortcut like ctrl + w and it works on that sheet without returning any value whatsoever, or confirming sheet name and all that.

Please if there's a way this can be done, I'd greatly appreciate.

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