VBA script that format celle with different color, slow spreadsheet - excel

Question

I'm brand new to VBA and this is my first VBA script, it seems good enough, but it's made my spreadsheet really slow, I can do something to optimize it.
The script runs through some defined columns and checks for content "A" "S" and so on, and if the content matches, the script must color the cell a specific color and also the cell on the right
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim My_Range As Range
Set My_Range = Worksheets("Sæson").Range("J10:J40,Q10:Q39,X10:X40,AE10:AE39,AL10:AL40,AS10:AS40,AZ10:AZ39,BG10:BG40,BN10:BN39,BU10:BU40,CB10:CB40,CI10:CI38,CP10:CP40")
For Each cell In My_Range
If cell.Value = "S" Then
cell.Interior.Color = RGB(0, 255, 255)
cell.Offset(0, 1).Interior.Color = RGB(0, 255, 255)
ElseIf cell.Value = "FE" Then
cell.Interior.Color = RGB(255, 192, 0)
cell.Offset(0, 1).Interior.Color = RGB(255, 192, 0)
ElseIf cell.Value = "SF" Then
cell.Interior.Color = RGB(255, 192, 0)
cell.Offset(0, 1).Interior.Color = RGB(255, 192, 0)
ElseIf cell.Value = "T" Then
cell.Interior.Color = RGB(49, 255, 33)
cell.Offset(0, 1).Interior.Color = RGB(49, 255, 33)
ElseIf cell.Value = "TK" Then
cell.Interior.Color = RGB(0, 176, 240)
cell.Offset(0, 1).Interior.Color = RGB(0, 176, 240)
ElseIf cell.Value = "TH" Then
cell.Interior.Color = RGB(255, 153, 204)
cell.Offset(0, 1).Interior.Color = RGB(255, 153, 204)
ElseIf cell.Value = "SY" Then
cell.Interior.Color = RGB(255, 0, 0)
cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
Else
cell.Interior.Color = xlNone
cell.Offset(0, 1).Interior.Color = xlNone
End If
Next
End Sub

Answer 1

As first option, you can also try to disable the ScreenUpdating option during the macro execution.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'variable declarations
'disable screen updating
Application.ScreenUpdating = False
'...
'code
'...
're-enable screen updating
Application.ScreenUpdating = True
End Sub

Answer 2

Apply Criteria Colors
It is assumed that the cells of the source range contain formulas. This will reapply colors to the whole range automatically (event-driven) each time the worksheet recalculates not necessarily meaning that a value in the range has changed (not quite efficient). It should be very fast on this small range though.
If the cells contain values then you can manually run applyCriteriaColors to get the desired result. Also, a solution would then be a different code written for the Worksheet_Change event (you cannot use this one).
Copy the codes to the appropriate modules.
Adjust the values in the constants section.
Standard Module e.g. Module1
Option Explicit
Sub applyCriteriaColors()
Const wsName As String = "Sheet1"
' The number of columns to apply the color to.
Const ColCount As Long = 2
' "cRangesList" has to contain a list of addresses of ONE-column ranges.
Const cRangesList As String = "J10:J40,Q10:Q39,X10:X40,AE10:AE39," _
& "AL10:AL40,AS10:AS40,AZ10:AZ39,BG10:BG40,BN10:BN39,BU10:BU40," _
& "CB10:CB40,CI10:CI38,CP10:CP40"
' "CriteriaList" and "CellColors" have to have the same number of elements.
' Note that "Ranges" has the same number of elements (ranges) as well.
Const CriteriaList As String = "S,FE,SF,T,TK,TH,SY"
Dim CellColors As Variant: CellColors = VBA.Array( _
16776960, 49407, 49407, 2228017, 15773696, 13408767, 255)
' Write values from Criteria List to Criteria Array.
Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
' Calculate Ranges Count (not to be confused with "aCount").
Dim rCount As Long: rCount = UBound(Criteria) + 1
' Define Ranges Array.
Dim Ranges() As Range: ReDim Ranges(1 To rCount)
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range.
Dim srg As Range: Set srg = wb.Worksheets(wsName).Range(cRangesList)
' Calculate Source Range Areas Count, the number of elements in Data Array.
Dim aCount As Long: aCount = srg.Areas.Count
' Define Data Array (of Arrays).
Dim Data As Variant: ReDim Data(1 To aCount)
' Define One-Cell Array.
Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1)
Dim arg As Range ' Source Range Current Area
Dim cValue As Variant ' Current Value
Dim cMatch As Variant ' Current Match
Dim n As Long ' Source Range Areas Counter, Ranges Array Ranges Counter
Dim i As Long ' Current Array (of Data Array) Rows Counter
For n = 1 To aCount
' Write values from current area ('srg.Areas(n)') of Source Range
' ('srg') to current array ('Data(n)') of Data Array ('Data').
Set arg = srg.Areas(n) '.Columns(1) ' ... ONE-column ranges
If arg.Rows.Count > 1 Then
Data(n) = arg.Value
Else
Data(n) = OneCell: Data(1, 1) = arg.Value
End If
For i = 1 To UBound(Data(n), 1)
cValue = Data(n)(i, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
' Attempt to find a match in Criteria Array.
cMatch = Application.Match(cValue, Criteria, 0)
If IsNumeric(cMatch) Then
' Combine matched cell resized by "ColCount"
' with 'associated' range in Ranges Array.
If Ranges(cMatch) Is Nothing Then
Set Ranges(cMatch) _
= arg.Cells(i).Resize(, ColCount)
Else
Set Ranges(cMatch) = Union(Ranges(cMatch), _
arg.Cells(i).Resize(, ColCount))
End If
End If
End If
End If
Next i
Next n
Application.ScreenUpdating = False
' Reset colors. Note that "Resize" doesn't work with multi-area ranges.
For n = 1 To aCount
srg.Areas(n).Resize(, ColCount).Interior.Color = xlNone
Next n
' Apply colors to the 'combined' ranges.
For n = 1 To rCount
If Not Ranges(n) Is Nothing Then
Ranges(n).Interior.Color = CellColors(n - 1)
End If
Next n
Application.ScreenUpdating = True
End Sub
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
applyCriteriaColors
End Sub