Selection change VBA has slowed Excel

[andrewb90]

Hello all,

I have this code in place:

    Range("G18:M28").Interior.Color = xlNone    Range("G18:M28").Font.Bold = False
    Set S = Application.Intersect(Range(Target.Address), Range("G18:M28"))
    If Not S Is Nothing Then
        Range("G" & Target.Row & ":M" & Target.Row).Interior.ColorIndex = 6  'Yellow
        Range("G" & Target.Row & ":M" & Target.Row).Font.Bold = True
    End If

Now, I have several more areas of the sheet where the same thing applies as well (just different ranges). I just added the bold font line, and now every time I click in a cell in the range, I see my mouse turning as it loads (briefly, less than half a second), but I am not sure why there is a lag. I can't really think that doing this little would cause excel to slow down, so I'm at a loss. I can send the entire code as I currently have it, if that would help.

One other point to mention, is when I added the bold font to just one of the ranges, I had no trouble, when I did it to all 8 (will have 14 sections total), that is when I found a lag in the response.
Any thoughts would be greatly appreciated!

Andrew

 

[ukmikeb]

Hi Andrew

For RwArray each element is the beginning of the next set of cells in AdArray.
So, for example if the next few sets of ranges are G103:N119 and G122:M132 you need to :-
1, add 120,122 and 133 to RwArray
2, specify the intervening unused range in G120:G121

For WdArray (the width of the range)
ie 7 for Gnnn:Mnnn, 8 for Gnnn:Nnnn and 0 (zero) for the "unused" range which is outside of the intersect but is put there for continuity should you wish to change the range allocations in future.
So for the example above you need to :-
1, add the following to WdArray 8,0,7

AdArray, as you have guessed is for defining the ranges of cells. But you need also to specify the intervening unused cells as a range for Column G only for continuity.
In the light of this re-definition AdArray in the previous post will become :-

AdArray = Array("$G$1:$G$17", "$G$18:$M$28", "G29:N35", "G36:M38", "G39:N41", "G42:M43", "G44:G44", "G45:M77", "G78:G78", "G79:M86", "G87:G87", "G88:M102")

I think you could replace the line :-

If Not S Is Nothing Then

with

If S Is Nothing Then Exit Sub

and remove the last "End If" and re-align the code indentation.

There is one point about the code that is likely to cause a problem. It currently will remove the colouring and Bold font for cells in column G which are outside the intersect ranges.

If you need the revised code to avoid this or have any further questions. Please get back to me.

With regard to the comments made by @rjwebgraphix I would like to point out that if your "Selection" is just one cell then this code is fine. However, if the user was to make the selection multi-cell by Shift-Enter or Control-Click then the approach here would have to be revised.

hth

 

[ukmikeb]

Hi Andrew

Sorry I missed out on the Used/Unused array (UsArray) which denotes whether that range of cells in the Address array (AdArray) is used (1) or unused (0).
A way to remove that could be possible if you could guarantee that column G would never intersect on its own.

hth

 

[andrewb90]

Hi Mike,

I think I understand so far......I will try making changes and go from there. One other question that does come to mind is, if I needed to apply changes to a different column range (say G:P?). Hopefully, I won't need it, but it would be nice to figure out how to do that. (I have an idea, but with VBA, I find I am frequently wrong)

Thanks,

Andrew

 

[andrewb90]

I have this in place right now (your original code) and I can't get it to highlight anything. Did I do something wrong?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim NewRange As Range
Dim Cell As Range
Dim S As Range
Dim AdArray(), RwArray(), UsArray(), WdArray()
Dim I As Long, Ps
RwArray = Array(18, 29, 36, 39, 42, 44, 45, 78, 79, 87, 88, 103)
WdArray = Array(0, 7, 8, 7, 8, 7, 0, 7, 0, 7, 0, 7, 0)
AdArray = Array(, "$G$18:$M$28", "G29:N35", "G36:M38", "G39:N41", "G42:M43", "G44:M44", "G45:M77", "G78:M78", "G79:M86", "G87:M87", "G88:M102")
UsArray = Array(0, 1, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1)


Application.EnableEvents = False


Set NewRange = Range(AdArray(1))
For I = 2 To UBound(UsArray, 1)
    If UsArray(I) Then
'    Add Ranges according to a 1 setting in UsArray
        Set NewRange = Application.Union(NewRange, Range(AdArray(I)))
    End If
 Next I
 
 Set S = Intersect(Target, NewRange)
 
 If Not S Is Nothing Then
 
     For Each Cell In Range("G18:G" & RwArray(UBound(RwArray, 1)) - 1)
'        Clear all previously highlighted rows
        If Cell.Interior.ColorIndex = 6 Then
            Ps = Application.WorksheetFunction.Match(Cell.Row, RwArray, 1)
            With Cell.Resize(1, WdArray(Ps))
                 .Interior.ColorIndex = None
                 .Font.Bold = False
            End With
      End If
   Next Cell
'  Find the position of the Intersect Row in the Row Array
Ps = Application.WorksheetFunction.Match(S.Row, RwArray, 1)
    
    With Range("G" & S.Row).Resize(1, WdArray(Ps))
'    Fill in/Bold Font the Intersect Row for the correct number of columns
        .Interior.ColorIndex = 6
        .Font.Bold = True
    End With
End If
Application.EnableEvents = True
End Sub

 

[ukmikeb]

Andrew

I have changed your code slightly to this :-

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim NewRange As Range
Dim Cell As Range
Dim S As Range
Dim AdArray(), RwArray(), UsArray(), WdArray()
Dim I As Long, Ps
RwArray = Array(18, 29, 36, 39, 42, 44, 45, 78, 79, 87, 88, 103)
WdArray = Array(0, 7, 8, 7, 8, 7, 0, 7, 0, 7, 0, 7, 0)
AdArray = Array("G1:G17", "G18:M28", "G29:N35", "G36:M38", "G39:N41", "G42:M43", "G44:G44", "G45:M77", "G78:G78", "G79:M86", "G87:G87", "G88:M102")
UsArray = Array(0, 1, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1)

Set NewRange = Range(AdArray(1))
For I = 2 To UBound(UsArray, 1)
    If UsArray(I) Then
'    Add Ranges according to a 1 setting in UsArray
        Set NewRange = Application.Union(NewRange, Range(AdArray(I)))
    End If
 Next I
 
 Set S = Intersect(Target, NewRange)
 
 If S Is Nothing Then Exit Sub

Application.EnableEvents = False

     For Each Cell In Range("G18:G" & RwArray(UBound(RwArray, 1)) - 1)
'        Clear all previously highlighted rows
        If Cell.Interior.ColorIndex = 6 Then
            Ps = Application.WorksheetFunction.Match(Cell.Row, RwArray, 1)
            With Cell.Resize(1, WdArray(Ps))
                 .Interior.ColorIndex = None
                 .Font.Bold = False
            End With
      End If
   Next Cell
'  Find the position of the Intersect Row in the Row Array
Ps = Application.WorksheetFunction.Match(S.Row, RwArray, 1)
    
    With Range("G" & S.Row).Resize(1, WdArray(Ps))
'    Fill in/Bold Font the Intersect Row for the correct number of columns
        .Interior.ColorIndex = 6
        .Font.Bold = True
    End With

Application.EnableEvents = True

End Sub

with the changes as follows :-
1, Split the first line "Private Sub.......Dim NewRange..." into separate lines
2, Moved the "Application.EnableEvents = False" statement from before the first "Set NewRange..." statement to after the intersection test statement (see 3)
3, Reversed the intersection test to "If S is Nothing then Exit Sub"
4, Removed the "End If" statement (which closes the intersection test) before the "Application.EnableEvents = True" statement
5, Tidied up the AdArray definition statement to refer to all Address Ranges with those outside the specified Ranges being defined as eg "G44:G44" single column ranges

Regards your question about changing the ranges eg "G36:M38" to "G36:P38" you can do that.
You would also have to change the relative position in WdArray from 7 to 10, in this case the 4th element, accordingly.

There are two possibilities why the code isn't working correctly :-
1, The combined Private Sub...Dim NewRange is causing the event not to be actioned or
2, The incorrect position of the statement to disable Application Events was causing the intersect test not to be actioned.


hth

 

[andrewb90]

How are the numbers in the UsArray determined?

 

[andrewb90]

Hey Mike,

So I've attempted to adjust the code with just a few areas to make sure I am making changes correctly, and now, nothing is running anymore.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim NewRange As Range
Dim Cell As Range
Dim S As Range
Dim AdArray(), RwArray(), UsArray(), WdArray()
Dim I As Long, Ps
RwArray = Array(13, 24, 31, 34, 37)
WdArray = Array(0, 7, 8, 7, 8, 7)
AdArray = Array("G1:M12", "G13:M23", "G24:N30", "G31:M33", "G34:N36", "G37:M38")
UsArray = Array(0, 1, 1, 1, 1, 1)


Set NewRange = Range(AdArray(1))
For I = 2 To UBound(UsArray, 1)
    If UsArray(I) Then
'    Add Ranges according to a 1 setting in UsArray
        Set NewRange = Application.Union(NewRange, Range(AdArray(I)))
    End If
 Next I
 
 Set S = Intersect(Target, NewRange)
 
 If S Is Nothing Then Exit Sub


Application.EnableEvents = False


     For Each Cell In Range("G1:G" & RwArray(UBound(RwArray, 1)) - 1)
'        Clear all previously highlighted rows
        If Cell.Interior.ColorIndex = 6 Then
            Ps = Application.WorksheetFunction.Match(Cell.Row, RwArray, 1)
            With Cell.Resize(1, WdArray(Ps))
                 .Interior.ColorIndex = None
                 .Font.Bold = False
            End With
      End If
   Next Cell
'  Find the position of the Intersect Row in the Row Array
Ps = Application.WorksheetFunction.Match(S.Row, RwArray, 1)
    
    With Range("G" & S.Row).Resize(1, WdArray(Ps))
'    Fill in/Bold Font the Intersect Row for the correct number of columns
        .Interior.ColorIndex = 6
        .Font.Bold = True
    End With


Application.EnableEvents = True


End Sub

 

[ukmikeb]

Hi Andrew

1, You still have the first line doubled up as stated in my previous post.

Having changed the Array(AdArray)
1, the last element of RwArray must be the number of the row after the last row in your quoted ranges ie 39
2, the last element of WdArray must be 0 to reflect the change in 1 above
3, the last element of UsArray must be 0 to reflect the change in 1 above

Please replace the following section of code :-

     For Each Cell In Range("G1:G" & RwArray(UBound(RwArray, 1)) - 1)
'        Clear all previously highlighted rows
        If Cell.Interior.ColorIndex = 6 Then
            Ps = Application.WorksheetFunction.Match(Cell.Row, RwArray, 1)
            With Cell.Resize(1, WdArray(Ps))
                 .Interior.ColorIndex = None
                 .Font.Bold = False
            End With
      End If
   Next Cell

with

     For Each Cell In Range("G" & RwArray(LBound(RwArray, 1)) & ":G" & RwArray(UBound(RwArray, 1)) - 1)
'        Clear all previously highlighted rows
'        except those rows not liable to intersect rules
    If Cell.Interior.ColorIndex = 6 Then
         Ps = Application.WorksheetFunction.match(Cell.Row, RwArray, 1)
            If WdArray(Ps) > 0 Then
                ' The width of the highlighted area must be greater than 0 (0 denotes area outside of intersection ranges)
                With Cell.Resize(1, WdArray(Ps))
                    .Interior.ColorIndex = None
                    .Font.Bold = False
                End With
            End If
    End If
Next Cell

If you still have problems may I suggest that you save the module having set a breakpoint in the code. Then set further breakpoints so you can monitor the execution accordingly.

I'll get back to you tomorrow, Tuesday.

hth

 

[ukmikeb]

Hi Andrew

I have completely revised the code so that the only Array to be specified is AdArray which defines the Ranges of interest.

The tested code is as follows :-

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim NewRange As Range
Dim PInt As Range
Dim TInt As Range
Dim AdArray()
Dim I As Long

AdArray = Array("G1:M12", "G13:M23", "G24:N30", "G31:M33", "G34:N36", "G37:M38")

Set NewRange = Range(AdArray(0))
For I = 1 To UBound(AdArray, 1)
'    Combine specified Ranges
    Set NewRange = Application.Union(NewRange, Range(AdArray(I)))
 Next I
 
 Set TInt = Intersect(Target, NewRange)
 
 If TInt Is Nothing Then Exit Sub
 
 Application.EnableEvents = False
 
For I = 0 To UBound(AdArray, 1)
'        Clear all previously highlighted rows that satisfy intersect rules
    With Range(AdArray(I))
        .Interior.ColorIndex = None
        .Font.Bold = False
    End With
Next I
For I = 0 To UBound(AdArray, 1)
' Search the specified Ranges for correct row to be highlighted
    Set PInt = Intersect(TInt, Range(AdArray(I)))
    If Not PInt Is Nothing Then
'             Range row found in specified ranges
        With Range("G" & TInt.Row).Resize(1, Range(AdArray(I)).Columns.Count)
'               Fill in/Bold Font the Intersect Row for the correct number of columns
            .Interior.ColorIndex = 6
            .Font.Bold = True
        End With
     End If
Next I
Application.EnableEvents = True
End Sub

hth

 

[andrewb90]

Hi Mike,

I appreciate what you have done so far, but I seem to have encountered 2 issues. The first is that when I select outside the specified ranges, my last row is still highlighted. The second is that now the code runs even slower than before.

Thanks,

Andrew