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

Posted 2023-03-06

【中文标题】通过双击突出显示 MS excel 2007 中的单元格

【英文标题】：Highlight cells in MS excel 2007 by double click

【发布时间】：2015-10-11 21:16:48

【问题描述】：

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

此代码突出显示 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

【参考方案1】：

建议您使用Worksheet_BeforeDoubleClick 方法通过将双击单元格的引用放在隐藏的工作表上来跟踪“突出显示”单元格，然后在事件处理程序中使用条件格式或显式检查以突出显示相关单元格（或“单元格”，如果您允许选择多行上的单个单元格）基于隐藏工作表上的值。如果您选择使用条件格式，每当“双击”新单元格时，隐藏工作表上的引用就会更新，并且会自动重新计算条件格式。给定行中只有一个单元格会一直保持“突出显示”。

或者，您可以通过按照以下行调整双击事件处理代码来显式执行此操作：

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If (Not (IsEmpty(Worksheets("Sheet2").Cells(1, 1).Value))) Then
        ActiveSheet.Range(Worksheets("Sheet2").Cells(1, 1).Value).Interior.ColorIndex = 0
    End If
    Worksheets("Sheet2").Cells(1, 1).Value = Target.Address
    ActiveSheet.Range(Worksheets("Sheet2").Cells(1, 1).Value).Interior.ColorIndex = 3
End Sub

这样，您还可以在加载工作表时检查任何突出显示的单元格，并在适当时重置它们（假设允许用户保存更改）。

要突出显示任何给定行上的一个单元格（但允许多行有一个突出显示的单元格），您可以使用以下命令（这也会在已突出显示的单元格中切换突出显示）：

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If (Not (IsEmpty(Worksheets("Sheet2").Cells(Target.Row, 1).Value))) Then
        ActiveSheet.Range(Worksheets("Sheet2").Cells(Target.Row, 1).Value).Interior.ColorIndex = 0
        If (Worksheets("Sheet2").Cells(Target.Row, 1).Value = Target.Address) Then
            Worksheets("Sheet2").Cells(Target.Row, 1).Value = ""
            Target.Interior.ColorIndex = 0
        Else
            Worksheets("Sheet2").Cells(Target.Row, 1).Value = Target.Address
            Target.Interior.ColorIndex = 3
        End If
    Else
        Worksheets("Sheet2").Cells(Target.Row, 1).Value = Target.Address
        Target.Interior.ColorIndex = 3
    End If
    Cancel = True
End Sub

【讨论】：

它可以工作，但是它将突出显示的单元格的引用放在行的第一个单元格中，我不希望这样，请问您有其他解决方案吗？

@Mohammad Mbydeen - 我发布了一个替代方案，将突出显示的单元格作为单独的答案存储在内存中。

【参考方案2】：

试试这个：

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    'Target must be between column "A" which is 1 & "G" which is 7 and also between row 1 and 10.
    'I also add checking for row. If you don't need, remove it.
    If Target.Column >= 1 And Target.Column <= 7 And Target.row >= 1 And Target.row <= 10 Then

      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 If

End Sub

【讨论】：

谢谢！！但是这段代码只针对一列，我想要行的范围，你能帮忙吗？

不清楚您的要求。用一些例子说更多。我会试试的。

这是问题所在，我有一个白色背景的表，用户可以通过单击分配给宏的按钮向表中添加行和列，我希望用户能够突出显示表格内的单元格，因为表格的背景是白色的，整个工作表的背景是灰色的，使用您的代码它会更改整行的背景。表格来自 A:G，可以扩展

好的，我知道了。我为你修改我的答案。试试吧。如果可行，请接受答案。谢谢！

【参考方案3】：

我相信您想将单元格颜色重置为普通单元格，而不是专门用白色背景填充它。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Cancel = True
    Dim iCOLOR As Long
    If Target.Interior.ColorIndex <> 3 Then _
        iCOLOR = 3
    Rows(Target.Row).Interior.Pattern = xlNone
    If iCOLOR = 3 Then _
        Target.Interior.ColorIndex = iCOLOR

End Sub

去除填充的方法是设置.Interior.Pattern = xlNone。

如果在不是红色时需要纯白色单元格填充，则可以使用它打开和关闭它。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Cancel = True
    Dim iCOLOR As Long
    iCOLOR = 3 + CBool(Target.Interior.ColorIndex = 3)
    Rows(Target.Row).Cells.Interior.ColorIndex = 2
    Target.Interior.ColorIndex = iCOLOR

End Sub

当然，ListObject 会带来一系列不同的问题。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    If Not Intersect(Target, ListObjects("Table1").DataBodyRange) Is Nothing Then
        Cancel = True
        Dim iCOLOR As Long
        iCOLOR = 3 + CBool(Target.Interior.ColorIndex = 3)
        Intersect(Rows(Target.Row), ListObjects("Table1").DataBodyRange).Interior.ColorIndex = 2
        Target.Interior.ColorIndex = iCOLOR
    End If

End Sub

【讨论】：

谢谢，但是你的代码改变了表格背景和工作表中整行的背景，我不想改变整行的背景。当用户单击以突出显示单元格时，它只是突出显示为红色并取消突出显示为白色。请问你能帮忙吗？？

目前尚不清楚要将单元格填充设置为白色的宽度，但如果这是首选，那么我已调整上面的代码以将整行回填为白色，以便两个单元格不能为红色同时在同一行。

这是问题所在，我有一个白色背景的表，用户可以通过单击分配给宏的按钮向表中添加行和列，我希望用户能够突出显示表格内的单元格，因为表格的背景是白色的，整个工作表的背景是灰色的，使用您的代码它会更改整行的背景。表格来自 A:G，可以扩展

很高兴知道您正在处理 listobject 表这一事实。

【参考方案4】：

可以将突出显示的单元格引用存储在内存中，而不是将选定的单元格引用存储在单独的或隐藏的工作表中。它们只需要在加载工作表时进行初始化（通过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

【讨论】：

很高兴听到@Mohammad Mbydeen。也许你可以投票表示感谢:)