Worksheet_Change - including multiple named cells

[EEEEEE]

Hi,

I want to run a filter when one of twenty named cells are changed. Problem is I can only add two cells to the 'set cells', I need to add twenty. Also the filter runs on 800 cells, is there anyway to speed it up a little? Thanks in advance. ( I'm not an expert at VBA )



Private Sub Worksheet_Change(ByVal Target As Range)



'Sets sheet password
'sheetpassword = "password"

'Sets Sheet Name variable (registers the current month sheet name)
'Sheetname = ActiveSheet.Name


'unlock sheet
' Worksheets(Sheetname).Unprotect Password:=sheetpassword



Dim cell As Range



'Cells that cause the change.
Set cell = Range("rides", "animals")
If Not Application.Intersect(cell, Range(Target.Address)) Is Nothing Then
Application.ScreenUpdating = False

'Clear the filter in the worksheet
Worksheets("Field_BOOKING & PROFILE FORM").AutoFilterMode = False


'Select the range to be filtered
Application.Goto Reference:="Booking_form_Entire_form"
Selection.AutoFilter
ActiveSheet.Range("Booking_form_Entire_form").AutoFilter Field:=1, Criteria1:="SHOW"

Else

End If



'protect sheet
Worksheets(Sheetname).Protect Password:=sheetpassword

Application.ScreenUpdating = True


End Sub

 

[Marcelo Branco]

To add more than two ranges

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range, sRng As String
    
    'Using 4 ranges: rides, animals, Range3 and Range4
    sRng = Range("rides").Address & "," & Range("animals").Address & "," _
        & Range("Range3").Address & "," & Range("Range4").Address
    
    Set cell = Range(sRng)
    
    If Not Intersect(Target, cell) Is Nothing Then
        MsgBox "Ok" 'just to check
        'more code
    End If
End Sub

Hope this helps

M.

 

[EEEEEE]

Awesome!! Thanks so much. Worked perfectly.

 

[Marcelo Branco]

You are welcome. Glad to help

M.

 

[EEEEEE]

Hi Marcel or another clever person,

The above code was working great until I tried to add over 33 named ranges, causes an error at Set cell = Range(sRng)

It doesn't seem to matted which named range I try to add it just causes an error with anymore over 33. Error is Range(sRng) =<method 'range'="" of="" object'="" _worksheet'="" failed=""></method>

Its really frustrating as I tried the same code on a different workbook and it worked fine with more than 33 named ranges, the ranges were all below each other and not spread out over 800 cells though and I used short names it Range1, Range2, Range3....etc rather than the longer names I have below to identify them easily.

Any suggestions, please??

Code I'm using is:


Private Sub Worksheet_Change(ByVal Target As Range)


Dim cell As Range, sRng As String

'Using ranges:
sRng = Range("booking_display_status").Address & "," & Range("Event_seasonal").Address & "," _
& Range("Event_single").Address & "," & Range("multiple_events").Address & "," _
& Range("facilities_finished").Address & "," & Range("temp_infra").Address & "," _
& Range("electrical").Address & "," & Range("noise").Address & "," _
& Range("external_av").Address & "," & Range("vehicleaccess_tsrp").Address & "," _
& Range("vehicleaccess_tsg").Address & "," & Range("vehicle_access_other").Address & "," _
& Range("catering_conducted").Address & "," & Range("Catering_hirer").Address & "," _
& Range("Catering_external").Address & "," & Range("Hirer_vans_stalls").Address & "," _
& Range("Externals_vans_stalls").Address & "," & Range("external_medicalprovider").Address & "," _
& Range("external_exhibits_special_activities").Address & "," & Range("pyrotechnics_flames_smoke").Address & "," _
& Range("Rides").Address & "," & Range("animals").Address & "," _
& Range("Booking_No_rides").Address & "," & Range("Field_External_Provider_No").Address & "," _
& Range("alcohol_served").Address & "," & Range("Profile_Security_alcohol_event").Address & "," _
& Range("Profile_Security_non_alcohol_event").Address & "," & Range("Security_commissioned").Address & "," _
& Range("Security_Volunteer").Address & "," & Range("Waste_Management_required").Address & "," _
& Range("traffic_management_plan_required").Address & "," & Range("Prohibited_items").Address & "," _
& Range("Amenities").Address & "," & Range("Field_Form_Finished").Address

Set cell = Range(sRng)

If Not Intersect(Target, cell) Is Nothing Then

'sets the starting cell
Dim myActiveCell As Range
Set myActiveCell = Selection


'Unlock current sheet
'Sets sheet password
sheetpassword = "password"



'Sets Sheet Name variable (registers the current month sheet name)
Sheetname = ActiveSheet.Name


'unlock sheet - must specify sheet name
Worksheets(Sheetname).Unprotect Password:=sheetpassword

'more code
Application.ScreenUpdating = False
'Clear the filter
Worksheets("Field_Enquiry & Profile Form").AutoFilterMode = False
'Select the range to be filtered
Application.Goto Reference:="Booking_form_Entire_form"
Selection.AutoFilter
ActiveSheet.Range("Booking_form_Entire_form").AutoFilter Field:=1, Criteria1:="SHOW"
'protect sheet - must specify sheet name
'Worksheets(Sheetname).Protect Password:=sheetpassword

Application.ScreenUpdating = True
'Selects the starting cell
myActiveCell.Select



End If





End Sub


Many thanks

 

[MoshiM]

Hi,

I want to run a filter when one of twenty named cells are changed. Problem is I can only add two cells to the 'set cells', I need to add twenty. Also the filter runs on 800 cells, is there anyway to speed it up a little? Thanks in advance. ( I'm not an expert at VBA )



Private Sub Worksheet_Change(ByVal Target As Range)



'Sets sheet password
'sheetpassword = "password"

'Sets Sheet Name variable (registers the current month sheet name)
'Sheetname = ActiveSheet.Name


'unlock sheet
' Worksheets(Sheetname).Unprotect Password:=sheetpassword



Dim cell As Range



'Cells that cause the change.
Set cell = Range("rides", "animals")
If Not Application.Intersect(cell, Range(Target.Address)) Is Nothing Then
Application.ScreenUpdating = False

'Clear the filter in the worksheet
Worksheets("Field_BOOKING & PROFILE FORM").AutoFilterMode = False


'Select the range to be filtered
Application.Goto Reference:="Booking_form_Entire_form"
Selection.AutoFilter
ActiveSheet.Range("Booking_form_Entire_form").AutoFilter Field:=1, Criteria1:="SHOW"

Else

End If



'protect sheet
Worksheets(Sheetname).Protect Password:=sheetpassword

Application.ScreenUpdating = True


End Sub

Have you tried using the application. union function and then nesting them within each other if needed.
https://docs.microsoft.com/en-us/office/vba/api/excel.application.union