Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, cOlZ As Long, strOk As Long, strZ As Long
Dim tMp As Variant
Dim cLr As Boolean
Dim Workbook As Workbook
Set Workbook = ActiveWorkbook
With ThisWorkbook
'ВСТАВЛЯЕМ ТОЛЬКО ЗНАЧЕНИЯ
If Target.Columns.Count > 6 Then Exit Sub
If Cells(1, 1).Value > 0 Then
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
If Application.CutCopyMode Then
        Application.EnableEvents = 0
        Application.Undo: Target.PasteSpecial xlPasteValues
        Application.EnableEvents = -1
End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End If

'ТЕКСТ В ЧИСЛА
  If Cells(1, 1).Value > 0 Then
   Dim rArea As Range
   On Error Resume Next ' обработчик ошибок
   'ActiveWindow.RangeSelection   ' диапазон выбранных ячеек листа даже если выбран графический объект
   'ActiveWindow.RangeSelection.SpecialCells(xlCellTypeConstants).Select ' в выбранном диапазоне выделить ячейки с константами _
   так будет быстрее, чем обрабатывать все ячейки в Selection
   If Err Then Exit Sub ' если нужных ячек не оказалось, то их невозможно выбрать и будет ошибка
   With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With ' отключаем все замедляющие процедуры

   For Each rArea In Selection.Areas 'т.к. выбранными скорее всего окажутся не смежные ячейки, а области, то обрабатывать нужно каждую из областей
      rArea.FormulaLocal = rArea.FormulaLocal ' значения во всех ячейках области заменить на них же. При этом произойдёт обновление форматов (это такая не документированная особенность Excel)
   Next rArea
   With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With ' включаем все обратно в обычный режим.
  End If
  
'УСТАНОВКА ОДИНОЧНОГО КОММЕНТАРИЯ НАЧАЛО
If Target.Columns.Count > 6 Then Exit Sub
If Cells(1, 1).Value = 2 Then

   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
   Application.EnableEvents = True
   Application.DisplayStatusBar = True
   Application.DisplayAlerts = True
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
  
    Dim vValue
    On Error Resume Next
    If Target <> vValue Then Target.Interior.Color = vbGreen
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End If
 'УСТАНОВКА ГРУППОВОГО КОММЕНТАРИЯ КОНЕЦ
 
'УСТАНОВКА ОДИНОЧНОГО КОММЕНТАРИЯ НАЧАЛО2
If Target.Columns.Count > 6 Then Exit Sub
If Sheets("Бюджет").Cells(10, 138).Value = 1 Then
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
ActiveSheet.Unprotect Password:="123"
    Dim OldComment As String, NewComment As String, objCell As Range
    If Target.Cells.Count = 1 Then
    NewComment = Now() & "; " & Application.UserName
    If Target.Comment Is Nothing Then
        Target.AddComment NewComment
    Else
        OldComment = Target.Comment.Text
        Target.Comment.Text NewComment & vbLf & OldComment
    End If
    Target.Comment.Shape.TextFrame.AutoSize = True
    Target.Comment.Visible = True
    DoEvents
        Target.Comment.Visible = False
 'УСТАНОВКА ОДИНОЧНОГО КОММЕНТАРИЯ КОНЕЦ2
 'УСТАНОВКА ГРУППОВОГО КОММЕНТАРИЯ НАЧАЛО2
    Else
    Set cc = Selection.SpecialCells(xlCellTypeVisible)
    For Each c In cc
    NewComment = Now() & "; " & Application.UserName
    On Error Resume Next
    If c.Comment Is Nothing Then
        c.AddComment NewComment
    Else
        OldComment = c.Comment.Text
        c.Comment.Text NewComment & vbLf & OldComment
    End If
    c.Comment.Shape.TextFrame.AutoSize = True
    c.Comment.Visible = True
    DoEvents
        c.Comment.Visible = False
    i = i + 1
    Next
    End If
    ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True
        
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    End If
 'УСТАНОВКА ГРУППОВОГО КОММЕНТАРИЯ КОНЕЦ2

'''''''''''''''''''''''''''''''''''''''''''''''
'ЗАМЕНА ПУСТЫХ НА ДРАНТЯ
If Target.Column = 12 Then
If Target.Value = "" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Dim cell As Range 'переменная для перебора ячеек
        Dim r As Range 'переменная для диапазона используемых ячеек
   For Each cell In Selection
lRow = Cells(Rows.Count, 23).End(xlUp).Row + 1
'lRow = Selection.Row 'первая строка
lLastrowInSelectedRange = Selection.Row + Selection.Rows.Count - 1 'последняя строка
        If cell.Value = "" Then
If lLastrowInSelectedRange < lRow Then
            cell.Value = "90001676"
End If
        End If
   Next
   End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
   End If
 '''''''''''''''''''''''''''''''''''''''''''''''
'ЗАМЕНА НУЛЕЙ И ТЕКСТА
'If Target.Column = 15 Then
    'Application.EnableEvents = False
    'For Each cel In Target.Cells
    '    If Application.WorksheetFunction.IsText(cel) Then Application.Undo
    '    If cel.Value & "" = "0" Then Application.Undo
    'Next
   'Application.EnableEvents = True
'End If
 '''''''''''''''''''''''''''''''''''''''''''''''
If Target.Column <> 58 Then Exit Sub
Dim tx
    If Target.Count > 1 Then Exit Sub
    If Len(Target.Value) = 0 Then Exit Sub
    tx = Split(Target.Value, ",")
    For i = LBound(tx) To UBound(tx)
        If IsNumeric(tx(i)) Then
            If Val(tx(i)) > 12 Or Val(tx(i)) < 1 Then
                MsgBox "Ошибка!" & vbCrLf & vbCrLf & "Введите число или числа через запятую от 1 до 12" & vbCrLf & vbCrLf & "Нажмите 'ОК' и повторите"
                Exit Sub
            End If
        End If
    Next i
'Dim cell As Range 'переменная для перебора ячеек
 '       Dim r As Range 'переменная для диапазона используемых ячеек
        Set r = Range("BF14:BF10000") 'Все используемые ячейки
   For Each cell In r.Cells
        'Если один символ справа равен ","
        If Right(cell.Value, 1) = "," Then
            'замена значения ячейки на то же значение, но без последнего символа
            cell.Value = Left(cell.Value, Len(cell.Value) - 1)
        End If
   Next
'''''''''''''''''''''''''''''''''''''''''''''''''
'СНИМАЕМ АВОФИЛЬТР
Application.ScreenUpdating = False
'Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

Application.Run "Фильтр_очистить"
'''''''''''''''''''''''''''''''''''''''''''''''''
strZ = Target.Row
ActiveSheet.Unprotect Password:="123"
For cOlZ = 32 To 55
    If Left(Cells(strZ, cOlZ).Formula, 3) = "=IF" Then Exit For
Next cOlZ
If cOlZ >= 55 Then Exit Sub
strOk = strZ + 1
Do Until (Len(Cells(strOk, cOlZ)) = 0) Or (Left(Cells(strOk, cOlZ).Formula, 3) = "=IF")
    strOk = strOk + 1
Loop
strOk = strOk - 1
If cOlZ < 54 Then Range(Cells(strZ, cOlZ + 2), Cells(strOk, 55)).ClearContents
tMp = Split(Application.Substitute(Application.Substitute(Application.Substitute(Target.Value, " ", ""), Application.DecimalSeparator, "."), ",", "."), ".")
If UBound(tMp) < 0 Then Exit Sub
cLr = True
For i = 0 To UBound(tMp)
    If (Val(tMp(i)) <= 12) Or (Val(tMp(i)) >= 1) Then
        If cOlZ = 32 + 2 * (tMp(i) - 1) Then
            cLr = False
        Else
            Range(Cells(strZ, cOlZ), Cells(strOk, cOlZ + 1)).Copy Cells(strZ, 32 + 2 * (tMp(i) - 1))
        End If
    End If
Next i
If cLr Then Range(Cells(strZ, cOlZ), Cells(strOk, cOlZ + 1)).ClearContents
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 'СТАВИМ АВТОФИЛЬТР С ЗАПОМНЕНЫМИ ЗНАЧЕНИЯМИ
 Application.Run "Фильтр_поставить"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True
        
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
End With
End Sub

Public WithEvents app As Application
Private Sub Workbook_Open()
  Set app = Application
End Sub
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=120771&TITLE_SEO=120771-ischezayut-dannye-v-stroke-sostoyaniya-pri-ne-aktivnom-okne
Dim d As Range, summ As Double
If Target.Columns.Count > 100 Then Exit Sub 'выходим если выделен весь лист (сейчас 100 столбцов)
For Each d In Selection
  If IsNumeric(d.Value) Then
    summ = summ + d
  End If
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim CellCount As Variant, rng As Range
    For Each rng In Selection.Areas
        RowsCount = rng.Rows.Count
        ColumnsCount = rng.Columns.Count
        CellCount = CellCount + RowsCount * ColumnsCount
    Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Mysumm = Format(summ, "#,##0.000") 'после точки регулируем кол-во отображаемых нулей после запятой
    Application.StatusBar = "СУММА: " & Mysumm & "   КОЛИЧЕСТВО: " & CellCount
End Sub

Public WithEvents app As Application
Private Sub Workbook_Open()
  Set app = Application
End Sub
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim d As Range, summ As Double
For Each d In Selection
  If IsNumeric(d.Value) Then
    summ = summ + d
  End If
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim CellCount As Variant, rng As Range
    For Each rng In Selection.Areas     'перебираем все выделенные области
        RowsCount = rng.Rows.Count                          'число строк
        ColumnsCount = rng.Columns.Count                    'число столбцов
        CellCount = CellCount + RowsCount * ColumnsCount    'накапливаем общее число ячеек
    Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=120771&TITLE_SEO=120771-ischezayut-dannye-v-stroke-sostoyaniya-pri-ne-aktivnom-okne
    Application.StatusBar = "СУММА: " & summ & "   КОЛИЧЕСТВО: " & CellCount
End Sub

If Cells.Select Then Exit Sub 

Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'If Cells.Select Then Exit Sub
Dim d As Range, summ As Double
For Each d In Selection
  If IsNumeric(d.Value) Then
    summ = summ + d
  End If
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim CellCount As Variant, rng As Range
    For Each rng In Selection.Areas     'перебираем все выделенные области
        RowsCount = rng.Rows.Count                          'число строк
        ColumnsCount = rng.Columns.Count                    'число столбцов
        CellCount = CellCount + RowsCount * ColumnsCount    'накапливаем общее число ячеек
    Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Application.StatusBar = "СУММА: " & summ & "   КОЛИЧЕСТВО: " & CellCount
End Sub

ActiveCell.EntireRow(1).Select
Selection.Copy

Application.Run (b)

Private Sub Worksheet_Change(ByVal Target As Range)
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False 
    Dim vValue
    On Error Resume Next
       If Target <> vValue Then Target.Interior.Color = vbGreen
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False  
    Dim vValue
    On Error Resume Next
       If Target = 0 Then Target.Interior.Color = vbGreen
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False  
    Dim vValue
    On Error Resume Next
       If Target = 0 Then Target.Value = ""
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub