Code to auto filter - need to make it more efficient

[eazy899]

Hi,

I am using this code to auto filter across different sheets.

Could someone help make it more efficient please?

[/COLOR][COLOR=#333333]Private Sub Worksheet_Change(ByVal Target As Range)[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;">'
    On Error Resume Next
    If Not Intersect(Range("B1"), Target) Is Nothing Then
        Application.EnableEvents = False
        If Range("B1").Value = "" Then
        
    For Each Worksheet In ThisWorkbook.Worksheets
    On Error Resume Next
    If Worksheet.AutoFilterMode Then
        Worksheet.AutoFilterMode = False
    End If
    Next Worksheet
                
        Else
            Worksheets("Debtors").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Sales Invoices").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Accrued Income").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Accrued Grants").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Prepayments").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("GRNI").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Accrued Expense").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Losses").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Special Payments").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Provisions").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Contingent Liabilities").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Cap Commitments").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Rev Commitments").Range("A6").autofilter 2, Range("B1").Value
            Worksheets("Asset Additions").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Assets Held For Sale").Range("A3").autofilter 2, Range("B1").Value
                      
        End If
        Application.EnableEvents = True
    End If </code>[COLOR=#333333]End Sub[/COLOR][COLOR=#333333]

 

[mumps]

Can you explain in words what you are trying to do? Be as detailed as possible referring to specific cells, ranges and sheets.

 

[eazy899]

Can you explain in words what you are trying to do? Be as detailed as possible referring to specific cells, ranges and sheets.

I want to:
1) Choose an item from a drop down list in Cell B1 in a tab called Directorate.
2) I then want it to apply an auto filter across multiple sheets.

The vba code that I have here currently does that, however there is a small delay.
I would like to learn how to write it more efficiently so that I can both make it better and apply this learning in the future.

The names of the sheets and ranges are within the code below.

Hence Debtors Cell A3, apply an autofilter in column 2 for the value in b1.
This works but as you can see this applies to the majority of sheets.
As such, I would like to know if there is a way to write a code for all the sheets that have the same range & filter requirements to make it more efficient?

Is this okay as an explanation?

[SIZE=2][COLOR=#333333][FONT=Consolas]Private Sub Worksheet_Change(ByVal Target As Range)[LEFT]
[/LEFT][/FONT][/COLOR][/SIZE]<code style="background-color: transparent; color: rgb(87, 65, 35); font-family: monospace; font-size: 12px; font-style: normal; font-variant: normal; font-weight: 400; letter-spacing: normal; line-height: 12px; margin-bottom: 0px; margin-left: 0px; margin-right: 0px; margin-top: 0px; orphans: 2; padding-bottom: 0px; padding-left: 0px; padding-right: 0px; padding-top: 0px; text-align: left; text-decoration: none; text-indent: 0px; text-transform: none; -webkit-text-stroke-width: 0px; white-space: pre; word-spacing: 0px;">'
    On Error Resume Next
    If Not Intersect(Range("B1"), Target) Is Nothing Then
        Application.EnableEvents = False
        If Range("B1").Value = "" Then
        
    For Each Worksheet In ThisWorkbook.Worksheets
    On Error Resume Next
    If Worksheet.AutoFilterMode Then
        Worksheet.AutoFilterMode = False
    End If
    Next Worksheet
                
        Else
            Worksheets("Debtors").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Sales Invoices").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Accrued Income").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Accrued Grants").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Prepayments").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("GRNI").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Accrued Expense").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Losses").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Special Payments").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Provisions").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Contingent Liabilities").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Cap Commitments").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Rev Commitments").Range("A6").autofilter 2, Range("B1").Value
            Worksheets("Asset Additions").Range("A3").autofilter 2, Range("B1").Value
            Worksheets("Assets Held For Sale").Range("A3").autofilter 2, Range("B1").Value
                      
        End If
        Application.EnableEvents = True
    End If </code>[COLOR=#333333][LEFT][COLOR=#333333][FONT=monospace]End Sub[/FONT][/COLOR][/LEFT][/COLOR]

 

[mumps]

Try:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B1")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim ws As Worksheet
    For Each ws In Sheets(Array("Debtors", "Sales Invoices", "Accrued Income", "Prepayments", "GRNI", "Accrued Expense", "Losses", _
            "Special Payments", "Provisions", "Contingent Liabilities", "Cap Commitments", "Rev Commitments", "Asset Additions", "Assets Held For Sale"))
      ws.Range("A3").AutoFilter 2, Target.Value
    Next ws
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End If
End Sub

 

[eazy899]

Hi,

I used what you provided to re write my code as it didn't work when I implemented yours (I may have done something wrong).

My following code now works but there is 1 thing in it which I have never understood and would greatly appreciate if you could explain it.

It is as follows: (please explain how target works and what this means)

If Not Intersect(Range("B1"), Target) Is Nothing Then
        Application.EnableEvents = False

Regarding the rest of my amended code, it is as follows. Please bear in mind that I am still learning.

Private Sub Worksheet_Change(ByVal Target As Range)'
Dim xWs As Worksheet
'Intersection between 2 Ranges'
    On Error Resume Next    If Not Intersect(Range("B1"), Target) Is Nothing Then        Application.EnableEvents = False    'Remove Auto Filter        If Range("B1").Value = "" Then    For Each Worksheet In ThisWorkbook.Worksheets    On Error Resume Next    If Worksheet.AutoFilterMode Then        Worksheet.AutoFilterMode = False    End If    Next Worksheet                    Else    For Each ws In Sheets(Array("Debtors", "Sales Invoices", "Accrued Income", "Accrued Grants", "Prepayments", "GRNI", "Accrued Expense", "Losses", _    "Special Payments", "Provisions", "Contingent Liabilities", "Cap Commitments", "Rev Commitments", "Asset Additions", "Assets Held For Sale"))    ws.Range("A3").AutoFilter 2, Target.Value    Next ws                Worksheets("Rev Commitments").Range("A6").AutoFilter 2, Range("B1").Value                              End If        Application.EnableEvents = True    End IfEnd Sub

 

[eazy899]

Thanks. I have been able to learn about target, events and intersect now. I did not understand how they were linked but now looking at them together, I do.

Your advice was brilliant and has solved my issue. No need to follow up if you do not wish to.

Thanks again.

 

[mumps]

You are very welcome.