Code Check

[Miya]

Hi, what is wrong with this code i get application defined object errror


With Sheets("SecuritiesReport").Range("A5")
.AutoFilter Field:=4, Criteria1:="=DOMCORP", Operator:=xlOr, Criteria2:="=TEMP", _
Operator:=xlOr, Criteria3:="=UNDADMIN", Operator:=xlOr, Criteria4:="=RIGHTS", _
Operator:=xlOr, Criteria5:="=SUBMVMNT"
End With

 

[ZVI]

One more improvement for the seldom case then Rng is the single cell:

Option Explicit
Option Compare Text

' ZVI:2011-07-06 http://www.mrexcel.com/forum/showthread.php?t=561925
' Filter Rng-range by Criteria
' Arguments:
'   Rng      - filtered range without header
'   Criteria - (optional) filter criteria(s), range_without_header)/value/array_of_values
' Note:
'   Missing of Criteria means ShowAllData in Rng-range
' VBA calls:
'   MyFilter Range("D11:D1000"), Range("D2:D5")
'   MyFilter Range("D11:D1000"), Range("DynamicRange")  NOTE: Don't include Header to DynamicRange
'   MyFilter Range("D11:D1000"), "DOMCORP,TEMP,UNDADMIN,RIGHTS"
'   MyFilter Range("D11:D1000"), Array("DOMCORP","TEMP","UNDADMIN","RIGHTS")
 Sub MyFilter(ByVal Rng As Range, Optional Criteria)
  Dim a, b, i As Long, r As Long, s As String, Sh As Worksheet, v, x
  On Error GoTo exit_
  Set Sh = Rng.Parent
  Set Rng = Intersect(Sh.UsedRange, Rng)
  If IsMissing(Criteria) Then Rng.EntireRow.Hidden = False: Exit Sub
  a = Rng.Columns(1).Value
  If Not IsArray(a) Then
    ReDim a(1 To 1, 1 To 1)
    a(1, 1) = Rng.Value
  End If
  b = Criteria: If Not IsArray(b) Then b = Split(b, ",")
  r = Rng.Row
  Application.ScreenUpdating = False
  Rng.EntireRow.Hidden = True
  With Sh
    For i = 1 To UBound(a)
      v = a(i, 1)
      If VarType(v) = vbString Then v = Trim(v)
      For Each x In b
        If x = v Then
          s = s & r & ":" & r
          If Len(s) >= 240 Then
            .Range(s).EntireRow.Hidden = False
            s = ""
          Else
            s = s & ","
          End If
          Exit For
        End If
      Next
      r = r + 1
    Next
    If Len(s) > 1 Then .Range(Left(s, Len(s) - 1)).EntireRow.Hidden = False
  End With
exit_:
  Application.ScreenUpdating = True
  If Err Then MsgBox Err.Description
End Sub

Sub SetMyFilter1()
  MyFilter Range("D11:D1000"), Range("D2:D5")
End Sub

Sub SetMyFilter2()
  MyFilter Range("D11:D1000"), "DOMCORP,TEMP,UNDADMIN,RIGHTS"
End Sub

Sub SetMyFilter3()
  MyFilter Range("D11:D1000"), Array("DOMCORP", "TEMP", "UNDADMIN", "RIGHTS")
End Sub

Sub SetMyFilter4()
  MyFilter Range("D11:D1000"), "DOMCORP"
End Sub

Sub SetMyFilter5()
  MyFilter Range("D11:D11"), "TEMP"
End Sub

' Show all data in range
Sub ResetMyFilter()
  MyFilter Range("D11:D1000")
End Sub

 

[Miya]

One more improvement for the seldom case then Rng is the single cell:

Vladimir this is great. Can we Call this filter in Thisworkbook module so that when the user saves the workbook, the code will call this filter and apply the filter. The workbook will be shared.

Sub SetMyFilter3()
MyFilter Range("D11:D1000"), Array("DOMCORP", "TEMP", "UNDADMIN", "RIGHTS")
End Sub

 

[ZVI]

Can we Call this filter in Thisworkbook module so that when the user saves the workbook, the code will call this filter and apply the filter.

Try below code in ThisWorkbook module:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  MyFilter Sheets(1).Range("D11:D1000"), "DOMCORP,TEMP,UNDADMIN,RIGHTS"
End Sub