Option Explicit

Private WithEvents App As Application

Private Sub Workbook_Open()
    
    Set App = Application
    
End Sub

Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    ' Written by Philip Treacy, http://www.myonlinetraininghub.com/highlight-selected-cells-in-excel-and-preserve-cell-formatting
    '

    Dim RowShape As Shape, ColShape As Shape
    
    ' ************************************************
    ' Check if entire rows or columns are selected
    ' If they are then hide the shapes
    ' ************************************************
    
    If Target.Address = Selection.EntireRow.Address Then
    
        'If error occurs because shape does not exist, ignore the error
        On Error Resume Next
        
        Sh.Shapes("SelectedRow").Visible = msoFalse
        Sh.Shapes("SelectedCol").Visible = msoFalse
        
        'Return error handling to Excel
        On Error GoTo 0
        
        Exit Sub
        
    End If
    
    If Target.Address = Selection.EntireColumn.Address Then
    
        'If error occurs because shape does not exist, ignore the error
        On Error Resume Next
        
        Sh.Shapes("SelectedCol").Visible = msoFalse
        Sh.Shapes("SelectedRow").Visible = msoFalse
        
        'Return error handling to Excel
        On Error GoTo 0
        
        Exit Sub
        
    End If
    
    ' ************************************************
    
    
    ' ************************************************
    ' Create shapes on active sheet if they don't exist
    ' ************************************************
    
    ' Set RowShape and ColShape to be the SelectedRow and SelectedCol shapes respectively
    On Error Resume Next
    Set RowShape = Sh.Shapes("SelectedRow")
    Set ColShape = Sh.Shapes("SelectedCol")
    On Error GoTo 0
     
    'If RowShape doesn't exist, then create it
    If RowShape Is Nothing Then
        
        Sh.Shapes.AddLine(1, 1, 1, 1).Select
                
        With Selection.ShapeRange
    
            .Name = "SelectedRow"
            
            .Line.Weight = 2 ' Set line thickness e.g. 1, 1.5, 2 etc
            
            .Line.ForeColor.RGB = RGB(146, 208, 80) ' Light Green.
            'Can use vbBlack, vbWhite, vbRed, vbGreen, vbBlue , vbYellow, vbMagenta, vbCyan
            
            'DashStyle = msoLineDash
            ' Can use : msoLineSolid, msoLineSysDot, msoLineSysDash, msoLineDash, msoLineDashDot, msoLineLongDash, msoLineLongDashDot, msoLineLongDashDotDot
            ' Default is msoLineSolid and does not need to be specified
        
        End With
    
    End If
    
    
    'If ColShape doesn't exist, then create it
    If ColShape Is Nothing Then
    
        Sh.Shapes.AddLine(1, 1, 1, 1).Select
        
        With Selection.ShapeRange
    
            .Name = "SelectedCol"
            .Line.Weight = 2 ' Set line thickness e.g. 1, 1.5, 2 etc
            .Line.ForeColor.RGB = RGB(146, 208, 80) ' Light Green
                    
        End With
    
    End If
    
    ' ************************************************
    
    
    
    ' ************************************************
    ' Move the SelectedRow and SelectedCol shapes
    ' ************************************************
    With Sh.Shapes("SelectedRow")
    
        .Visible = msoTrue 'Make sure it is visible, it may have been hidden by previous selection
        .Top = Target.Top
        .Left = ActiveWindow.VisibleRange.Left
        .Width = ActiveWindow.VisibleRange.Width
              
    End With
    
    
    With Sh.Shapes("SelectedCol")
    
        .Visible = msoTrue 'Make sure it is visible, it may have been hidden by previous selection
        .Top = ActiveWindow.VisibleRange.Top
        .Left = Target.Left
        .Height = ActiveWindow.VisibleRange.Height
        
    End With
    
    ' ************************************************
    
    Target.Select ' Must do this to stop shape being selected if navigating with cursor keys

End Sub