Sub CountIfsRange()
Dim arr(), arrCond(), arrCount()
Dim iTmp
Dim I&, J&
On Error Resume Next
With ActiveSheet
  arr = .Range("A8:L" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
  arrCond = .Range("A6:L6").Value
  ReDim arrCount(1 To UBound(arr, 1), 1 To 1)
  For I = LBound(arr, 1) To UBound(arr, 1)
    For J = LBound(arrCond, 2) To UBound(arrCond, 2)
      If Not IsEmpty(arrCond(1, J)) Then
        If arr(I, J) = arrCond(1, J) Then
          arrCount(I, 1) = arrCount(I, 1) + 1
        End If
      ElseIf Not IsEmpty(arr(I, J)) Then
          arrCount(I, 1) = arrCount(I, 1) + 1
      End If
    Next
  Next
  .Range("N8").Resize(UBound(arrCount, 1)) = arrCount
End With
End Sub

Sub CountIfsDisplayFormat()
Dim iRng As Range
Dim dfCell As Range
Dim lRow&, I&, J&, arrCount()
On Error Resume Next
Application.ScreenUpdating = False
With ActiveSheet
  lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  Set iRng = .Range("A8:L" & lRow)
  ReDim arrCount(1 To iRng.Rows.Count, 1 To 1)
  Set dfCell = Application.InputBox(Prompt:="Выберите ячейку с цветом:", Type:=8)
  If Not dfCell Is Nothing Then
    For I = 8 To lRow
      N = N + 1
      For J = iRng.Columns(1).Column To iRng(iRng.Columns.Count).Column
        If .Cells(I, J).DisplayFormat.Interior.Color = dfCell.DisplayFormat.Interior.Color Then
          arrCount(N, 1) = arrCount(N, 1) + 1
        End If
      Next
    Next
  End If
  .Range("O8").Resize(UBound(arrCount, 1)) = arrCount
End With
Application.ScreenUpdating = True
End Sub

Public Const MyPass$ = "123"  'пароль

Sub Макрос1()
  Запуск_формы
  MsgBox "Выполняется Макрос1"
End Sub

Sub Макрос2()
  Запуск_формы
  MsgBox "Выполняется Макрос2"
End Sub

Sub Макрос3()
  Запуск_формы
  MsgBox "Выполняется Макрос3"
End Sub

Private Sub Запуск_формы()
  UserForm1.Show
End Sub 

'Отмена ввода пароля
Private Sub CommandButton1_Click()
  Unload Me
  End 'останавливаем ВСЕ макросы!!!
End Sub

Private Sub CommandButton2_Click()
  If TextBox1.Text <> MyPass Then
    MsgBox "Incorrect password!"
    End 'останавливаем ВСЕ макросы!!!
  End If
  Unload Me
End Sub

Sub SumIfMerge1()
Dim iCl As Range
Dim iAr As Range
Dim dtCell As Range
Dim iSum As Double
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each iCl In Cells(Selection.Rows(1).Row, 1).Resize(Selection.Rows.Count).Cells
  If iCl.MergeCells Then
    iSum = 0
    Set dtCell = Cells(iCl.MergeArea.Areas(1).Row, Selection.Column)
    For Each iAr In iCl.MergeArea.Cells
      iSum = iSum + Cells(iAr.Row, Selection.Column)
    Next
    dtCell.Offset(, 1) = iSum
  Else
    Set dtCell = Cells(iCl.Row, Selection.Column)
    dtCell.Offset(, 1) = dtCell
  End If
  Set dtCell = Nothing
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub