Option Explicit

Private mPrev As Object              ' Scripting.Dictionary
Private mPrevRange As Range          ' что подсвечивали в прошлый раз

Private Const FOCUS_COLOR As Long = 13828095 ' мягкий жёлтый (RGB(255, 255, 210))

Private mFocusEnabled As Boolean


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo ErrH
    
    If Not mFocusEnabled Then Exit Sub
    
    If Target Is Nothing Then Exit Sub
    If Target.Cells.CountLarge > 1 Then Set Target = Target.Cells(1, 1)

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    RestorePrevious
    ApplyFocus Target

SafeExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

ErrH:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description, vbExclamation
    Resume SafeExit
End Sub

Private Sub ApplyFocus(ByVal c As Range)
    Dim ur As Range, rngRow As Range, rngCol As Range, focusRng As Range
    Dim cell As Range, key As String

    Set ur = Me.UsedRange
    If ur Is Nothing Then Exit Sub
    
    If Intersect(c, ur) Is Nothing Then Exit Sub


    ' строка и столбец ограничены UsedRange
    Set rngRow = Intersect(Me.Range(ur.Cells(1, 1), ur.Cells(ur.Rows.Count, ur.Columns.Count)).EntireRow, Me.Rows(c.Row))
    Set rngRow = Intersect(rngRow, ur)

    Set rngCol = Intersect(Me.Range(ur.Cells(1, 1), ur.Cells(ur.Rows.Count, ur.Columns.Count)).EntireColumn, Me.Columns(c.Column))
    Set rngCol = Intersect(rngCol, ur)

    If rngRow Is Nothing And rngCol Is Nothing Then Exit Sub

    If rngRow Is Nothing Then
        Set focusRng = rngCol
    ElseIf rngCol Is Nothing Then
        Set focusRng = rngRow
    Else
        Set focusRng = Union(rngRow, rngCol)
    End If

    ' исключаем активную ячейку без "вычитания диапазонов"
    If mPrev Is Nothing Then Set mPrev = CreateObject("Scripting.Dictionary")
    mPrev.RemoveAll

    For Each cell In focusRng.Cells
        If cell.Address = c.Address Then
            ' пропускаем активную
        Else
            key = cell.Address(False, False)
            mPrev(key) = Array(cell.Interior.Pattern, cell.Interior.ColorIndex, cell.Interior.Color)
        End If
    Next cell

    ' подсветка
    For Each cell In focusRng.Cells
        If cell.Address <> c.Address Then
            cell.Interior.Pattern = xlSolid
            cell.Interior.Color = FOCUS_COLOR
        End If
    Next cell

    Set mPrevRange = focusRng
End Sub

Private Sub RestorePrevious()
    If mPrevRange Is Nothing Then Exit Sub
    If mPrev Is Nothing Then Exit Sub
    If mPrev.Count = 0 Then
        Set mPrevRange = Nothing
        Exit Sub
    End If

    Dim cell As Range, key As String, pack As Variant

    For Each cell In mPrevRange.Cells
        key = cell.Address(False, False)
        If mPrev.Exists(key) Then
            pack = mPrev(key)
            cell.Interior.Pattern = pack(0)

            If pack(1) = xlColorIndexNone Then
                cell.Interior.ColorIndex = xlColorIndexNone
            Else
                cell.Interior.Color = pack(2)
            End If
        End If
    Next cell

    Set mPrevRange = Nothing
    mPrev.RemoveAll
End Sub


Public Sub FocusOn()
    mFocusEnabled = True
End Sub

Public Sub FocusOff()
    mFocusEnabled = False
    RestorePrevious ' чтобы сразу убрать подсветку
End Sub

Public Sub FocusToggle()
    If mFocusEnabled Then
        FocusOff
    Else
        FocusOn
    End If
End Sub

'Private Sub Worksheet_Activate()
'    If mFocusEnabled = False Then mFocusEnabled = True
'End Sub