突出顯示單元格中的MS Excel 2007中通過雙擊

Question

我希望用戶能夠只突出對各行

該代碼突出了2007年的Excel單元格一個單元格，但我的問題是，我不能寫在限制用戶代碼來僅僅強調一個單元的一排，

這裏是代碼：

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

建議你使用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 

Answer 3

試試這個：

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 

Answer 4

我相信你想要的單元格顏色恢復到正常細胞，用白色背景沒有特別填充它。

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