Как изменить цвет ячейки при изменении выделения

Question

У меня есть ссылка на ячейку (D6:D33).В этом диапазоне ячеек, если я выберу D10, его цвет фона должен измениться на красный.Если снова выбрать ту же ячейку D10, цвет ее фона должен измениться на предыдущий.Точно так же он должен работать для любой ячейки, выбранной в диапазоне D6:D33.Как мне изменить мой неполный код ниже, чтобы сделать это?

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("D6:D33")) Is Nothing Then
           Range("D10").Interior.Color = RGB(255, 55, 55)
        End If
    End If
End Sub

Answer 1

True Colours

Версия с подсветкой (ADV)

При открытии книги все цвета записываются в массив.При изменении выделения, если выделение является ячейкой в ​​диапазоне, цвет изменится на красный, а предыдущий цвет будет записан в массив.Когда цвет красный, тогда будет применен прежний цвет, который находится в массиве, и красный цвет будет записан в массив и т. Д.

Исправлена ​​ошибка переполнения для версии 2007 и более поздних (CountLarge).Исправлена ​​ошибка «Нет цвета белого цвета».

Кредиты BigBen для указания различных ошибок.

Module1 :

Option Explicit

Public vnt1 As Variant
Public Const cRng As String = "D6:D33"
Public Const cColor As Long = 255

ThisWorkbook :

Option Explicit

Private Sub Workbook_Open()

  Dim i As Long

  With Range(cRng)
    ReDim vnt1(1 To .Rows.Count, 1 To 1) As Long
    For i = 1 To .Rows.Count
      With .Cells(i, 1).Interior
        If .ColorIndex <> xlNone Then
          vnt1(i, 1) = .Color
         Else
          vnt1(i, 1) = -1
        End If
      End With
    Next
  End With

  ' For i = 1 To UBound(vnt1)
  '   Debug.Print i & "  " & vnt1(i, 1)
  ' Next

End Sub

Лист1 :

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  Dim lngDiff As Long
  Dim lngTemp As Long

  If Val(Application.Version) >= 12 Then
    If Selection.Cells.CountLarge > 1 Then Exit Sub
   Else
    If Selection.Cells.Count > 1 Then Exit Sub
  End If

  lngDiff = Range(cRng).Row - 1

  If Not Intersect(Target, Range(cRng)) Is Nothing Then
    With Target.Interior
      If .Color <> cColor Then
        If .ColorIndex <> xlNone Then
          lngTemp = .Color
         Else
          lngTemp = -1
        End If
        vnt1(.Parent.Row - lngDiff, 1) = lngTemp
        .Color = cColor
       Else
        If vnt1(.Parent.Row - lngDiff, 1) <> -1 Then
          .Color = vnt1(.Parent.Row - lngDiff, 1)
         Else
          .ColorIndex = xlNone
        End If
        vnt1(.Parent.Row - lngDiff, 1) = cColor
      End If
    End With
  End If

End Sub

Красно-белая версия (INT)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  If Val(Application.Version) >= 12 Then
    If Selection.Cells.CountLarge > 1 Then Exit Sub
   Else
    If Selection.Cells.Count > 1 Then Exit Sub
  End If

  If Not Intersect(Target, Range("D6:D33")) Is Nothing Then
    If Target.Interior.Color <> RGB(255, 0, 0) Then
      Target.Interior.Color = RGB(255, 0, 0)
     Else
      Target.Interior.Color = RGB(255, 255, 255)
    End If
  End If

End Sub

Answer 2

Вы можете оставить только Dictionary выбранных ячеек:

Option Explicit

Dim colorsDict As Scripting.Dictionary

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count = 1 Then
        If Not Intersect(Target, Range("D6:D33")) Is Nothing Then
            If colorsDict Is Nothing Then Set colorsDict = New Scripting.Dictionary ' instantiate a dictionary object
            With colorsDict ' reference dictionary object
                If .Exists(Target.Address) Then ' if selected cell already in dictionary (i.e. already selected)
                    Target.Interior.Color = .Item(Target.Address) ' get its "original" color back
                    .Remove Target.Address ' remove its address from dictionary (i.e. as if it was never selected before) 
                Else ' if selected cell not in dictionary (i.e. not already selected)
                    .Add Target.Address, IIf(Target.Interior.Color = 16777215, xlNone, Target.Interior.Color) ' keep track of its original color storing it into dictionary with cell target as key
                    Target.Interior.Color = RGB(255, 55, 55) ' color the selected cell with red
                End If
            End With
        End If
    End If
End Sub

Answer 3

В модуле

Public vColor(6 To 33)
Sub setColor()
    Dim rng As Range
    Dim n As Integer
    n = 6
    For Each rng In Range("d6:d33")
        vColor(n) = rng.Interior.Color
        n = n + 1
    Next rng
End Sub

В коде листа

Private Sub Worksheet_Activate()
    setColor
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Count = 1 Then
        If Not Intersect(Target, Range("D6:D33")) Is Nothing Then
           If Target.Interior.Color = RGB(255, 55, 55) Then
                Target.Interior.Color = vColor(Target.Row)
            Else
                Target.Interior.Color = RGB(255, 55, 55)
            End If
        End If
    End If
End Sub