Microsoft 365 mettre en évidence cellule active

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Const couleurBord = "255 0 255"     ' couleur type RGB (rouge vert bleu)
Const largeurBord = 3
Dim couleurs, shp As Shape, D, X, Y, corrX, corrY
   Application.ScreenUpdating = False
   couleurs = Split(couleurBord)
   D = 3 * largeurBord
   With ActiveCell
      X = .Left - D: If X < 0 Then X = 0: corrX = -D
      Y = .Top - D: If Y < 0 Then Y = 0: corrY = -D
      On Error Resume Next
      Set shp = ActiveSheet.Shapes("Evidence")
      On Error GoTo 0
      If shp Is Nothing Then
         Set shp = .Parent.Shapes.AddShape(msoShapeRectangle, X, Y, .Width + 2 * D + corrX, .Height + 2 * D + corrY)
         shp.Name = "Evidence"
         shp.Fill.Visible = msoFalse
         shp.Line.ForeColor.RGB = RGB(couleurs(0), couleurs(1), couleurs(2))
         shp.Line.Weight = 3
         shp.Placement = xlMove
         shp.Placement = xlMoveAndSize
      Else
         shp.Left = X: shp.Top = Y: shp.Width = .Width + 2 * D + corrX: shp.Height = .Height + 2 * D + corrY
      End If
      On Error Resume Next: Selection.Select
      On Error GoTo 0
   End With
End Sub