Выделите ячейки в 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

Предлагайте используется метод 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