Координатное выделение

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Cells.Interior.ColorIndex = xlNone
    With Selection
     .Resize(.Rows.Count).EntireRow.Interior.Color = RGB(204, 255, 153)
     .Resize(.Column).EntireColumn.Interior.Color = RGB(204, 255, 153)
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    On Error Resume Next
    Dim x As Range: Set x = Range("B5:BM5001"): x.Interior.ColorIndex = xlNone
    'If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, x) Is Nothing Then
        Intersect(x, Target.EntireRow).Interior.Color = RGB(235, 247, 255)
        Intersect(x, Target.EntireColumn).Interior.Color = RGB(235, 247, 255)
        Target.Interior.ColorIndex = xlNone
    End If
End Sub 

Dim Coord_Selection As Boolean
Sub Selection_On()
    Coord_Selection = True
End Sub
Sub Selection_Off()
    Coord_Selection = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WorkRange As Range
[COLOR=#ee1d24]    If Target.Cells.Count > 1 Then Exit Sub[/COLOR]
    If Coord_Selection = False Then Exit Sub
    Application.ScreenUpdating = False
    Set WorkRange = Range("A1:CA500";)
    Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select
    Target.Activate
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WorkRange As Range
    On Error GoTo GetOut
    If Target.Cells.Count > 1 Then Exit Sub
    If Coord_Selection = False Then Exit Sub
    Application.ScreenUpdating = False
    Set WorkRange = Range("A1:CA500")
    Intersect(WorkRange, Union(Target.EntireColumn, Target.EntireRow)).Select
    Target.Activate  
GetOut:
End Sub

=И(ЯЧЕЙКА("строка")=СТРОКА(A1);ЯЧЕЙКА("столбец")<>СТОЛБЕЦ(A1))  

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WorkRange As Range
    Dim wi As Window
    Set wi = ActiveWindow
    If Target.Cells.Count > 1 Then Exit Sub  'если выделено больше 1 ячейки - выходим
 
    Application.ScreenUpdating = False
    Set WorkRange = wi.VisibleRange 'адрес рабочего диапазона, в пределах которого видно выделение
'    Intersect(WorkRange, Target.EntireRow).Select   'формируем строку диапазон и выделяем
    Intersect(WorkRange, Union(Target.EntireRow, Target.EntireColumn)).Select 'формируем крестообразный диапазон и выделяем
    Target.Activate
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)       
  With Target
    If .Areas.Count = 1 And .Rows.Count = 1 And Names("s.hgt") <> "=" & .Row Then Names("s.hgt").Value = .Row
  End With
End Sub

=СТРОКА()=s.hgt 

Target.FormatConditions.Delete

WorkRange.FormatConditions.Delete

Set CrossRange = Intersect(WorkRange, Union(Target.EntireRow, Target.EntireColumn))

Set CrossRange = Intersect(WorkRange, Target.EntireRow)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  
If Intersect(Target, Range("B1:J99")) Is Nothing Then Exit Sub
 ActiveCell.Calculate
End Sub
 

Private Sub Option_off_Click()
Cells(1, 1).Value = ""
End Sub

Private Sub Option_on_Click()
Cells(1, 1).Value = "Вкл"
End Sub
 

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = xlNone
With ActiveCell
    .EntireRow.Interior.ColorIndex = 40
    .EntireColumn.Interior.ColorIndex = 40
End With
End Sub

Private Sub Worksheet_Deactivate() 'если активируется другой лист и есть подсветка, то подсветка убирается
    Call restoreFill
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim dataRng As Range ' диапазон данных таблицы
Dim rowRng As Range ' диапазон ячеек в строке таблицы для подсветки
Dim celRng As Range ' ячейки в диапазоне подсветки rowRng
Dim n As Integer
    Call restoreFill
    If Range("A1").Interior.ColorIndex = xlNone Then Exit Sub 'если подсветка отключена, то выход
    If Target.Count > 1 Then Exit Sub 'если выделено больше одной ячейки
    Set dataRng = Range(Cells(7, 2), Cells(ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1, _
    ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1)) ' диапазон данных таблицы, Cells(7, 2) - адрес (начало) диапазона данных таблицы
    If Not Intersect(Target, dataRng) Is Nothing Then 'если ячейка выделена в диапазоне данных таблицы
        Set rowRng = Intersect(dataRng, Target.EntireRow) 'строка таблицы с выделенной ячейкой в диапазоне данных таблицы
        ReDim saveColor(rowRng.Cells.Count) 'размерность массива = ширина таблицы + нулевой элемент массива для адреса диапазона подсветки
        n = 0
        saveColor(n) = rowRng.Address 'адрес диапазона подсветки в нулевой элемент массива
        For Each celRng In rowRng 'перебор ячеек в диапазоне подсветки
            n = n + 1 'номер следующего элемента массива
            saveColor(n) = celRng.Interior.ColorIndex 'индекс заливки текущей ячейки в массив
        Next celRng
        rowRng.Interior.ColorIndex = Range("A1").Interior.ColorIndex 'заливка диапазона подсветки цветом заливки ячейки А1
        Target.Interior.ColorIndex = xlNone 'выделенная ячейка без заливки
    End If
    End Sub

Sub restoreFill() 'проверка включения подсветки, если подсветка была включена, то восстановление первоначальной (до подсветки) заливки в этой строке
Dim c As Integer
Dim cel_InRng As Range ' ячейки в диапазоне подсветки rowRng
    If (Not Not saveColor) <> 0 Then 'если массив не пустой (так проверяется массив, объявленный как Dim saveColor() ), т.е. диапазон подсветки был определен ранее
        c = 0
        For Each cel_InRng In Range(saveColor(0)) 'перебор ячеек в диапазоне, указанном в нулевом элементе массива
            c = c + 1 'номер следующего элемента массива
            cel_InRng.Interior.ColorIndex = saveColor(c) 'заливка ячеек цветами, сохраненными в массиве
        Next cel_InRng
        Erase saveColor 'удаление массива
    Else
        Exit Sub
    End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If ActiveSheet.Name = "Имя листа с таблицей" Then Call Sheets("Имя листа с таблицей").restoreFill  
End Sub

Public saveColor() ' адрес подсвечиваемого диапазона и сохраненные цвета заливки подсвечиваемых ячеек таблицы до подсветки

 Private Sub PopupMenuCreate() 'название макроса
    Dim bt As CommandBarControl 
    Set bt = Application.CommandBars("Cell").Controls.Add(before:=1) 
    bt.Caption = "Включить выделение": bt.OnAction = "Worksheet____3.Selection_On": bt.FaceId = 351 
    Dim bt1 As CommandBarControl 
    Set bt1 = Application.CommandBars("Cell").Controls.Add(before:=1) 
    bt1.Caption = "Выключить выделение": bt1.OnAction = "Worksheet____3.Selection_Off": bt1.FaceId = 352  
End Sub

Sub Vremja_2_chasa_nochi_a_ja_pishy_macros()
   Set objVBProj = ActiveWorkbook.VBProject
   Set objVBComp = objVBProj.VBComponents(Worksheets(1).CodeName)
' где Worksheets(1).CodeName - 1-й лист в книге, как бы он ни назывался  
   Set objCodeMod = objVBComp.CodeModule
' вставляем код
   With objCodeMod
      lLineNum = .CreateEventProc("SelectionChange", "Worksheet")
      lLineNum = lLineNum + 1
      .InsertLines lLineNum, "    ActiveCell.Calculate"
   End With 
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WorkRange As Range
    Set wi = ActiveWindow
    If Target.Cells.Count > 1 Then Exit Sub 
    
    Application.ScreenUpdating = False
    Set WorkRange = wi.VisibleRange 
    Intersect(WorkRange, Union(Target.EntireRow, Target.EntireColumn)).Select
    Target.Activate

End Sub 

If Target.Count > 1 Then Exit Sub 

On Error Resume Next   'при ошибке выполнит следующую процедуру
If Target.Count > 1 Then Exit Sub 

Option Explicit
Dim Coord_Selection As Boolean ' глобальная переменная для вкл/выкл выделения
Dim lastHighlightedRow As Long ' переменная для хранения последней выделенной строки

Sub Selection_On() ' макрос включения выделения
    Coord_Selection = True
    ' Сразу вызываем событие для текущей активной ячейки, чтобы выделение сразу появилось
    Call Worksheet_SelectionChange(ActiveCell)
End Sub

Sub Selection_Off() ' макрос выключения выделения
    Coord_Selection = False
    ' Убираем выделение с предыдущей строки
    If lastHighlightedRow > 0 Then
        ActiveSheet.Rows(lastHighlightedRow).Interior.ColorIndex = xlNone ' Убираем цвет заливки
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WorkRange As Range
    Dim lastRow As Long, LastColumn As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    LastColumn = 8 ' последняя колонка, которую нужно включить в диапазон
    Set WorkRange = ActiveSheet.Range(ActiveSheet.Cells(3, 1), ActiveSheet.Cells(lastRow, LastColumn)) ' адрес рабочего диапазона

    If Target.Count > 1 Then Exit Sub ' если выделено несколько ячеек, ничего не делаем

    Application.ScreenUpdating = False

    ' Если выделение включено и активная ячейка находится в диапазоне WorkRange
    If Coord_Selection = True And Not Intersect(Target, WorkRange) Is Nothing Then
        ' Убираем выделение с предыдущей строки
        If lastHighlightedRow > 0 Then
            ' Убираем заливку только для строк внутри диапазона
            If Not Intersect(ActiveSheet.Rows(lastHighlightedRow), WorkRange) Is Nothing Then
                ActiveSheet.Rows(lastHighlightedRow).Interior.ColorIndex = xlNone
            End If
        End If

        ' Ограничиваем выделение строки только теми ячейками, которые находятся в диапазоне WorkRange
        Dim RowRange As Range
        Set RowRange = Intersect(Target.EntireRow, WorkRange)

        If Not RowRange Is Nothing Then
            RowRange.Interior.Color = RGB(221, 235, 247) ' Цвет выделения для строки
        End If

        ' Убираем цвет заливки у активной ячейки
        Target.Interior.ColorIndex = xlNone

        lastHighlightedRow = Target.Row ' Сохраняем номер строки для последующего снятия выделения
    Else
        ' Если выделение выключено или Target вне диапазона
        If lastHighlightedRow > 0 Then
            ' Убираем заливку только для строк внутри диапазона
            If Not Intersect(ActiveSheet.Rows(lastHighlightedRow), WorkRange) Is Nothing Then
                ActiveSheet.Rows(lastHighlightedRow).Interior.ColorIndex = xlNone
            End If
            lastHighlightedRow = 0 ' Сбрасываем переменную
        End If
    End If

    Application.ScreenUpdating = True
End Sub
  

Option Explicit
Dim Coord_Selection As Boolean ' глобальная переменная для вкл/выкл выделения
Dim lastHighlightedRow As Long ' переменная для хранения последней выделенной строки
Dim lastHighlightedColumn As Long ' переменная для хранения последнего выделенного столбца

Sub Selection_On() ' макрос включения выделения
    Coord_Selection = True
    ' Сразу вызываем событие для текущей активной ячейки
    Call Worksheet_SelectionChange(ActiveCell)
End Sub

Sub Selection_Off() ' макрос выключения выделения
    Coord_Selection = False
    ' Убираем выделение с предыдущей строки и столбца
    If lastHighlightedRow > 0 Then
        ActiveSheet.Rows(lastHighlightedRow).Interior.ColorIndex = xlNone ' Убираем цвет заливки со строки
    End If
    If lastHighlightedColumn > 0 Then
        ActiveSheet.Columns(lastHighlightedColumn).Interior.ColorIndex = xlNone ' Убираем цвет заливки со столбца
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WorkRange As Range, CrossRange As Range
    Dim lastRow As Long, LastColumn As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    LastColumn = 8 ' последняя колонка, которую нужно выделить
    Set WorkRange = ActiveSheet.Range(ActiveSheet.Cells(3, 1), ActiveSheet.Cells(lastRow, LastColumn)) ' диапазон для выделения

    If Target.Count > 1 Then Exit Sub ' если выделено больше одной ячейки, ничего не делаем

    Application.ScreenUpdating = False

    ' Если выделение включено и активная ячейка находится в рабочем диапазоне
    If Coord_Selection = True And Not Intersect(Target, WorkRange) Is Nothing Then
        ' Убираем выделение с предыдущей строки и столбца
        If lastHighlightedRow > 0 Then
            ActiveSheet.Rows(lastHighlightedRow).Interior.ColorIndex = xlNone ' Убираем цвет заливки со строки
        End If
        If lastHighlightedColumn > 0 Then
            ActiveSheet.Columns(lastHighlightedColumn).Interior.ColorIndex = xlNone ' Убираем цвет заливки со столбца
        End If

        ' Ограничиваем выделение строк и столбцов внутри WorkRange
        Dim RowRange As Range
        Dim ColumnRange As Range

        ' Строка: выделяем только те ячейки в строке, которые входят в WorkRange
        Set RowRange = Intersect(Target.EntireRow, WorkRange)
        If Not RowRange Is Nothing Then
            RowRange.Interior.Color = RGB(221, 235, 247) ' Цвет выделения для строки
        End If

        ' Столбец: выделяем только те ячейки в столбце, которые входят в WorkRange
        Set ColumnRange = Intersect(Target.EntireColumn, WorkRange)
        If Not ColumnRange Is Nothing Then
            ColumnRange.Interior.Color = RGB(221, 235, 247) ' Цвет выделения для столбца
        End If

        ' Убираем цвет заливки у активной ячейки
        Target.Interior.ColorIndex = xlNone

        ' Сохраняем номер строки и столбца для последующего снятия выделения
        lastHighlightedRow = Target.Row
        lastHighlightedColumn = Target.Column
    Else
        ' Если выделение выключено или Target вне диапазона
        If lastHighlightedRow > 0 Then
            ActiveSheet.Rows(lastHighlightedRow).Interior.ColorIndex = xlNone ' Убираем цвет заливки со строки
            lastHighlightedRow = 0 ' Сбрасываем переменную
        End If
        If lastHighlightedColumn > 0 Then
            ActiveSheet.Columns(lastHighlightedColumn).Interior.ColorIndex = xlNone ' Убираем цвет заливки со столбца
            lastHighlightedColumn = 0 ' Сбрасываем переменную
        End If
    End If

    Application.ScreenUpdating = True
End Sub