VBA Stopped Working

Confusing....

What are
Private Sub Worksheet_SelectionChange_DI_75T(ByVal Target As Range)
Private Sub Worksheet_SelectionChange_DI_35T(ByVal Target As Range)
Private Sub Worksheet_SelectionChange_DI_Mate(ByVal Target As Range)

?

So, you want the whole code into one Selection_Change event?

No, you can't do it so...
Perhaps...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myCol As Range
    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            Select Case myArea(i).Column
                Case Is <= 7
                    Set myCol = Sheet5.Columns((myArea(i).Column \ 2) * 58 + 9)
                Case Is <= 13
                    Set myCol = Sheet7.Columns((myArea(i).Column \ 2 - 4) * 58 + 9)
                Case Else
                    Set myCol = Sheet9.Columns(IIf(myAreas(i).Column = 15, 9, 67))
            End Select
            myCol.Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
        Next
    Next
End Sub

Correction

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myCol As Range
    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            Select Case myArea(i).Column
                Case Is <= 7
                    Set myCol = Sheet5.Columns((myArea(i).Column \ 2) * 58 + 9)
                Case Is <= 13
                    Set myCol = Sheet7.Columns((myArea(i).Column \ 2 - 4) * 58 + 9)
                Case Else
                    Set myCol = Sheet8.Columns((myArea(i).Column \ 2 - 7) * 58 + 9)
            End Select
            myCol.Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
        Next
    Next
End Sub

You have clear regularity between columns to loop and columns to hide.
As your loop column index increases by 2 (A, C, E, G etc.), hide column increases by 58 columns.

Backslash operator in calculation gives you round down integer.
e.g
5 \ 2 = 2, which you can also rewrite like Application.RoundDown(5/ 2, 0), or Fix(5 / 2)

So, as loop column increases by 2, the result from that calculation will increase by 1.

-4, -7 in calculation are the adjustment for the hide column index.

I added the variable "myAdj", so you can do a step debug.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            Select Case myArea(i).Column
                Case Is <= 7
                    myAdj = 0
                    Set ws = Sheet5
                Case Is <= 13
                    myAdj = -4
                    Set ws = Sheet7
                Case Else
                    myAdj = -7
                    Set ws = Sheet8
            End Select
            ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
        Next
    Next
End Sub

HTH

It runs fine here.
Is any sheet protected?

If protected, add 2 lines

            ws.Parent.Unprotect
            ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
            ws.Parent.Protect

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            Select Case myArea(i).Column
                Case Is <= 7
                    myAdj = 0
                    Set ws = Sheet5
                Case Is <= 13
                    myAdj = -4
                    Set ws = Sheet7
                Case Else
                    myAdj = -7
                    Set ws = Sheet8
            End Select
            ws.Parent.Unprotect
            ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
            ws.Parent.Protect
        Next
    Next
End Sub

Still comes up with same error

Many thanks

OK, try this one then

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas
    myProtect False, Sheet5, Sheet7, Sheet8
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            Select Case myArea(i).Column
                Case Is <= 7
                    myAdj = 0
                    Set ws = Sheet5
                Case Is <= 13
                    myAdj = -4
                    Set ws = Sheet7
                Case Else
                    myAdj = -7
                    Set ws = Sheet8
            End Select
            ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
        Next
    Next
    myProtect True, Sheet5, Sheet7, Sheet8
End Sub

Private Sub myProtect(flg As Boolean, ParamArray x())
    Dim ws As Worksheet
    For Each ws In x
        If flg Then
            ws.Protect
        Else
            ws.Unprotect
        End If
    Next
End Sub

OOps,of course...
Change

    Dim ws As Worksheet

to

    Dim ws As Variant

I'm sorry,

This is now working

However,
When selecting a cell, it now jumps to the selected worksheet and asks for the password.
If I protect the sheet without a password, the screen flicks to the corresponding sheet then back again briefly.

Many thanks

If only one password for all the sheet

change to

Private Sub myProtect(flg As Boolean, ParamArray x())
    Dim ws As Variant
    For Each ws In x
        If flg Then
            ws.Protect "password"
        Else
            ws.Unprotect "password"
        End If
    Next
End Sub

Change password to suite

Awesome, that solves the asking for password issue.

However when selecting a cell, the screen is flickering to and from the worksheet accordingly
If for example I press down arrow to move down 5 cells, the screen flicks to and from 5 times.

Is there a way to stop this please?

Many thanks

Then add 2 lines

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas
    Application.ScreenUpdating = False  '<--- 1
    myProtect False, Sheet5, Sheet7, Sheet8
    .
    .
    .
    myProtect True, Sheet5, Sheet7, Sheet8
    Application.ScreenUpdating = True  '<---- 2
End Sub

Cool, getting there

Your help is really appreciated!

Now when selecting cells, the sheet has to think for a second or 2 before I can do anything.

Resolvable?

Many thanks

I don't think so.
If they are the rows to be hidden, autofilter could be applied.

However, it can be narrowed the range of Selection.
The current code will run for each one of the cell regardless of the cell selected, but if it limit to the change within the fixed range, it can be much faster.

I've found that if I leave the password blank to protect the sheet, it works so much faster and more acceptable.

Many thanks for your assistance Jindon, very much appreciated
+1 to your reputation

You are welcome and thanks for the rep.

Sorry,
Think I'm being dumb

Can't get sheet9 to work

Please can you tell me where I going wrong:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas
    Application.ScreenUpdating = False  '<--- 1
    myProtect False, Sheet5, Sheet7, Sheet8, Sheet9
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            Select Case myArea(i).Column
                Case Is <= 7
                    myAdj = 0
                    Set ws = Sheet5
                Case Is <= 13
                    myAdj = -4
                    Set ws = Sheet7
                Case Is <= 19
                    myAdj = -7
                    Set ws = Sheet8
                Case Else
                    myAdj = -10
                    Set ws = Sheet9
            End Select
            ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
        Next
    Next
    myProtect True, Sheet5, Sheet7, Sheet8, Sheet9
    Application.ScreenUpdating = True  '<---- 2
End Sub

Private Sub myProtect(flg As Boolean, ParamArray x())
    Dim ws As Variant
    For Each ws In x
        If flg Then
            ws.Protect ""
        Else
            ws.Unprotect ""
        End If
    Next
End Sub

Many thanks

Hi
Your range is up to col.S, which is column index of 19.

    Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53").Areas

So it will never go in to Case Else

                Case Is <= 19 ' it always up to here.
                    myAdj = -7
                    Set ws = Sheet8
                Case Else
                    myAdj = -10
                    Set ws = Sheet9
            End Select

Even that took a moment to register an understanding lol.
I was looking at it referring to sheet9 being the problem, not the source list on the main sheet in question.

I have now edited the code accordingly and believe I now have it fully functional:

Set myAreas = Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53,u4:u53,w3:w53,y3:y53,AA3:AA53").Areas

Beginning to make more sense.

Thankyou Thankyou Thankyou

OK, one thing though.

Subscript of Range must be less than 255 characters.

Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54,k4:k53,m4:m53,o4:o53,q4:q53,s4:s53,u4:u53,w3:w53,y3:y53,AA3:AA53")

If you ever need to extend the range and exceed the limit, use Union method like

Set myAreas = Union(Range("a4:a53,c4:c53,e4:e53,g4:g53,i4:i54"),Range("k4:k53,m4:m53,o4:o53,q4:q53,s4:s53"),Range("u4:u53,w3:w53,y3:y53,AA3:AA53")).Areas

That makes sense,

In my case, I've split it up into categories, so to make things more simplified, I've applied the ranges into those categories:

Set myAreas = Union(Range("a4:a53,c4:c53,e4:e53,g4:g53"), Range("i4:i54,k4:k53,m4:m53"), Range("o4:o53,q4:q53,s4:s53"), Range("u4:u53,w3:w53,y3:y53,AA3:AA53")).Areas

Many thanks

Something strange has happened

This script has been working perfectly until all of a sudden recently

All of a sudden I'm getting the following error and one of the lines when I go into debug highlights yellow:

error.jpg

I have confirmed the sheet is unprotected.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Set myAreas = Union(Range("a4:a53,c4:c53,e4:e53,g4:g53"), Range("i4:i54,k4:k53,m4:m53"), Range("o4:o53,q4:q53,s4:s53"), Range("u4:u53,w3:w53,y3:y53,AA3:AA53")).Areas
    Application.ScreenUpdating = False  '<--- 1
    myProtect False, Sheet5, Sheet7, Sheet8, Sheet9
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            Select Case myArea(i).Column
                Case Is <= 7
                    myAdj = 0
                    Set ws = Sheet5
                Case Is <= 13
                    myAdj = -4
                    Set ws = Sheet7
                Case Is <= 19
                    myAdj = -7
                    Set ws = Sheet8
                Case Else
                    myAdj = -10
                    Set ws = Sheet9
            End Select
            ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
        Next
    Next
    myProtect True, Sheet5, Sheet7, Sheet8, Sheet9
    Application.ScreenUpdating = True  '<---- 2
End Sub

Private Sub myProtect(flg As Boolean, ParamArray x())
    Dim ws As Variant
    For Each ws In x
        If flg Then
            ws.Protect "", Contents:=True, DrawingObjects:=False, UserInterfaceOnly:=True, AllowFormattingCells:=True
        Else
            ws.Unprotect ""
        End If
    Next
End Sub

Any ideas please ?

Many thanks

Can not replicate the issue,

If the cell value possibly have Error then change to

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Set myAreas = Union(Range("a4:a53,c4:c53,e4:e53,g4:g53"), Range("i4:i54,k4:k53,m4:m53"), _
        Range("o4:o53,q4:q53,s4:s53"), Range("u4:u53,w3:w53,y3:y53,AA3:AA53")).Areas
    Application.ScreenUpdating = False  '<--- 1
    myProtect False, Sheet5, Sheet7, Sheet8, Sheet9
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            If Not IsError(myArea(i).Value) Then
                Select Case myArea(i).Column
                    Case Is <= 7
                        myAdj = 0
                        Set ws = Sheet5
                    Case Is <= 13
                        myAdj = -4
                        Set ws = Sheet7
                    Case Is <= 19
                        myAdj = -7
                        Set ws = Sheet8
                    Case Else
                        myAdj = -10
                        Set ws = Sheet9
                End Select
                ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
            End If
        Next
    Next
    myProtect True, Sheet5, Sheet7, Sheet8, Sheet9
    Application.ScreenUpdating = True  '<---- 2
End Sub

Private Sub myProtect(flg As Boolean, ParamArray x())
    Dim ws As Variant
    For Each ws In x
        If flg Then
            ws.Protect "", Contents:=True, DrawingObjects:=False, UserInterfaceOnly:=True, AllowFormattingCells:=True
        Else
            ws.Unprotect ""
        End If
    Next
End Sub

Hmm,

This has really baffled me...

I was trying to delete parts of the spreadsheet so I could send the file to here for you to see, (still not succeeded in that lol), when I went though each sheet and deleted the comments.

Once all comments were deleted, I noticed the script then working again, behaving as designed.

After a bit of digging, I found that there is a comment on Sheet5 Cell GB18, which all it says is 'at Alsbury', delete this comment on its own, (leaving all the others in place), and the script is working.

Strange thing is, if I delete the comment and re-insert it (even with using copy/paste), the script carries on working.

The additional lines in the script above did not solve the problem unfortunately.

Still can not replicate the issue here.

Have deleted as much as I can with error in place

File attached.

Many thanks.

See if this works,

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim myAreas As Areas, myArea As Range, i As Long, ws As Worksheet, myAdj As Long
    Dim sp As Shape
    Set myAreas = Union(Range("a4:a53,c4:c53,e4:e53,g4:g53"), Range("i4:i54,k4:k53,m4:m53"), _
        Range("o4:o53,q4:q53,s4:s53"), Range("u4:u53,w3:w53,y3:y53,AA3:AA53")).Areas
    Application.ScreenUpdating = False  '<--- 1
    myProtect False, Sheet5, Sheet7, Sheet8, Sheet9
    For Each myArea In myAreas
        For i = 1 To myArea.Count
            If Not IsError(myArea(i).Value) Then
                Select Case myArea(i).Column
                    Case Is <= 7
                        myAdj = 0
                        Set ws = Sheet5
                    Case Is <= 13
                        myAdj = -4
                        Set ws = Sheet7
                    Case Is <= 19
                        myAdj = -7
                        Set ws = Sheet8
                    Case Else
                        myAdj = -10
                        Set ws = Sheet9
                End Select
                On Error Resume Next
                For Each sp In ws.Shapes
                    sp.Placement = 1
                Next
                On Error GoTo 0
                ws.Columns((myArea(i).Column \ 2 + myAdj) * 58 + 9).Offset(, myArea(i).Row - 4).Hidden = myArea(i).Value = 0
            End If
        Next
    Next
    myProtect True, Sheet5, Sheet7, Sheet8, Sheet9
    Application.ScreenUpdating = True  '<---- 2
End Sub

Private Sub myProtect(flg As Boolean, ParamArray x())
    Dim ws As Variant
    For Each ws In x
        If flg Then
            ws.Protect "", Contents:=True, DrawingObjects:=False, UserInterfaceOnly:=True, AllowFormattingCells:=True
        Else
            ws.Unprotect ""
        End If
    Next
End Sub

For some reason, this is taking ages when clicking in a different cell
Circle busy icon goes round for quite some time before the cell becomes usable.

Not so bad on the file attached here, but in the original, is taking 30-60secs.

many thanks

Cool, That's working

When returning to Setup sheet, I see something going on in bottom left of screen but can't make out what its doing lol.

Fault has now gone and script is working again.

Many thanks for your assistance, Very much appreciated.