通过双击突出显示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

Answer 2

我相信您想将细胞颜色重置为正常细胞，而不是专门用白色背景填充它。

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

Answer 3

建议您使用Worksheet_BeforeDoubleClick方法跟踪突出显示的＆＃39;通过在隐藏的工作表上放置双击单元格的引用，然后在事件处理程序中使用条件格式或显式检查来突出显示相关单元格（或者＃34;单元格＆＃34;如果您允许单个单元格基于隐藏工作表上的值，选择多行上的单元格。如果您选择使用条件格式，则只要双击新单元格，就会在隐藏的工作表上更新引用，并自动重新计算条件格式。只有给定行上的一个单元格才会被突出显示＆＃39;。

或者，您可以通过调整双击事件处理代码来明确地执行此操作：

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

Answer 4

试试这个：

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