vba - 通过双击突出显示 MS excel 2007 中的单元格

Question

我希望用户能够只突出显示每一行的一个单元格

此代码突出显示 excel 2007 中的单元格，但我的问题是我无法编写代码来限制用户仅突出显示一行中的一个单元格，

代码如下:

Private Sub Worksheet_BeforeDoubleClick( _


     ByVal Target As Range, Cancel As Boolean)

' This macro is activated when you doubleclick
' on a cell on a worksheet.
' Purpose: color or decolor the cell when clicked on again
' by default color number 3 is red
      If Target.Interior.ColorIndex = 3 Then
            ' if cell is already red, remove the color:
            Target.Interior.ColorIndex = 2
      Else
            ' make the cell red:
            Target.Interior.ColorIndex = 3
      End If
      ' true to cancel the 'editing' mode of a cell:
      Cancel = True

End Sub

Answer 1

与其将选定的单元格引用存储在单独的或隐藏的工作表中，不如将突出显示的单元格引用存储在内存中。它们只需要在加载工作表时进行初始化(通过 Worksheet_Activate() 方法)，但在其他方面将以类似的方式工作。

将以下代码添加到工作簿中的相关工作表:

' Set of highlighted cells indexed by row number
Dim highlightedCells As New Collection

' Scan existing sheet for any cells coloured 'red' and initialise the
'  run-time collection of 'highlighted' cells.
Private Sub Worksheet_Activate()
    Dim existingHighlights As Range
    ' Reset the collection of highlighted cells ready to rebuild it
    Set highlightedCells = New Collection
    ' Find the first cell that has its background coloured red
    Application.FindFormat.Interior.ColorIndex = 3
    Set existingHighlights = ActiveSheet.Cells.Find("", _
                                                    LookIn:=xlValues, _
                                                    LookAt:=xlPart, _
                                                    SearchOrder:=xlByRows, _
                                                    SearchDirection:=xlNext, _
                                                    MatchCase:=False, _
                                                    SearchFormat:=True)
    ' Process for as long as we have more matches
    Do While Not existingHighlights Is Nothing
        cRow = existingHighlights.Row
        ' Add a reference only to the first coloured cell if multiple
        ' exist in a single row (will only occur if background manually set)
        Err.Clear
        On Error Resume Next
            Call highlightedCells.Add(existingHighlights.Address, CStr(cRow))
        On Error GoTo 0
        ' Search from the cell after the last match. Note an error in Excel
        '  appears to prevent the FindNext method from finding formats correctly
        Application.FindFormat.Interior.ColorIndex = 3
        Set existingHighlights = ActiveSheet.Cells.Find("", _
                                                    After:=existingHighlights, _
                                                    LookIn:=xlValues, _
                                                    LookAt:=xlPart, _
                                                    SearchOrder:=xlByRows, _
                                                    SearchDirection:=xlNext, _
                                                    MatchCase:=False, _
                                                    SearchFormat:=True)
        ' Abort the search if we've looped back to the top of the sheet
        If (existingHighlights.Row < cRow) Then
            Exit Do
        End If
    Loop

End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim hCell As String
    Dim cellAlreadyHighlighted As Boolean
    hCell = ""

    Err.Clear
    On Error Resume Next
      hCell = highlightedCells.Item(CStr(Target.Row))
    On Error GoTo 0

    If (hCell <> "") Then
        ActiveSheet.Range(hCell).Interior.ColorIndex = 0
        If (hCell = Target.Address) Then
            Call highlightedCells.Remove(CStr(Target.Row))
            Target.Interior.ColorIndex = 0
        Else
            Call highlightedCells.Remove(CStr(Target.Row))
            Call highlightedCells.Add(Target.Address, CStr(Target.Row))
            Target.Interior.ColorIndex = 3
        End If
    Else
        Err.Clear
        On Error Resume Next
          highlightedCells.Remove (CStr(Target.Row))
        On Error GoTo 0
        Call highlightedCells.Add(Target.Address, CStr(Target.Row))
        Target.Interior.ColorIndex = 3
    End If
    Cancel = True
End Sub