Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'скрыть все
'ActiveSheet.Outline.ShowLevels 1, 1

'раскрыть все
ActiveSheet.Outline.ShowLevels 2, 1

End Sub

Sub СкрытьПустые()
Dim i&
Application.ScreenUpdating = False
    For i = 30 To Cells(Rows.Count, 1).End(xlUp).Row   'Определяем что скрытие пустых строк начнется с 30 строки
    'Далее определяем какие диапазоны столбцов мы отслеживаем, если во всех указанных диапазонах пусто, то идет скрытие строки
     If WorksheetFunction.CountA(Range("D" & i & ":H" & i)) = 0 _
     And WorksheetFunction.CountA(Range("J" & i & ":J" & i)) = 0 _
     And WorksheetFunction.CountA(Range("L" & i & ":L" & i)) = 0 _
     And WorksheetFunction.CountA(Range("N" & i & ":P" & i)) = 0 _
     And WorksheetFunction.CountA(Range("R" & i & ":R" & i)) = 0 _
     And WorksheetFunction.CountA(Range("T" & i & ":V" & i)) = 0 _
     And WorksheetFunction.CountA(Range("X" & i & ":Y" & i)) = 0 _
     And WorksheetFunction.CountA(Range("AA" & i & ":AA" & i)) = 0 Then
     Rows(i).EntireRow.Hidden = True
    End If
    Next
Application.ScreenUpdating = True
End Sub

Sub ОтобразитьПустые()
Rows("30:9999").Hidden = False  'Показать скрытые строки в диапазоне 

End Sub

Sub СкрытьПустыеДиапазона2()
    Dim i1 As Long, i2 As Long
    Application.ScreenUpdating = False
    i1 = Selection.Cells(1).Row  'Определяем переменную i1 - первая строка выделенного диапазона
    i2 = Selection.Cells(Selection.Cells.Count).Row   'Определяем переменную i2 - последняя строка выделенного диапазона
    Rows(i1).Resize(i2 - i1 + 1).Hidden = True 'Скрываются строки в диапазоне. Почему так не понятно. Rows("i1:i2") не работает
    Application.ScreenUpdating = True

End Sub

Sub СкрытьПустыеДиапазона2()
    Dim i1 As Long, i2 As Long
    Application.ScreenUpdating = False
'    For i = 7 To Cells(Rows.Count, 1).End(xlUp).Row   'Определяем что скрытие пустых строк начнется с 7 строки
    i1 = Selection.Cells(1).Row  'Определяем переменную i1 - первая строка выделенного диапазона
    i2 = Selection.Cells(Selection.Cells.Count).Row   'Определяем переменную i2 - последняя строка выделенного диапазона
     If WorksheetFunction.CountA(Range("D" & i & ":H" & i)) = 0 _
     And WorksheetFunction.CountA(Range("J" & i & ":J" & i)) = 0 _
     And WorksheetFunction.CountA(Range("L" & i & ":L" & i)) = 0 _
     And WorksheetFunction.CountA(Range("N" & i & ":P" & i)) = 0 _
     And WorksheetFunction.CountA(Range("R" & i & ":R" & i)) = 0 _
     And WorksheetFunction.CountA(Range("T" & i & ":V" & i)) = 0 _
     And WorksheetFunction.CountA(Range("X" & i & ":Y" & i)) = 0 _
     And WorksheetFunction.CountA(Range("AA" & i & ":AA" & i)) = 0 Then
    Rows(i1).Resize(i2 - i1 + 1).Hidden = True 'Скрываются строки в диапазоне. 
    End If
'    Next
Application.ScreenUpdating = True

End Sub

Option Explicit
Dim wks As Worksheet
Dim Проект()        As Variant
Dim Исполнитель()   As Variant
Dim ДатаВып()       As Variant
Dim ДнейДо()        As Variant

Sub remindAtStartup()
    Dim Просрочено As String
    Dim i As Long
    Set wks = ThisWorkbook.Worksheets("Лист1")
    
    setArray Проект, "Проект"
    setArray Исполнитель, "Исполнитель"
    setArray ДатаВып, "ДатаВып"
    setArray ДнейДо, "СрокДо"
       
    'генерирование напоминаний
    Просрочено = ""
    
    For i = 1 To UBound(Проект)
        Select Case ДнейДо(i, 1)
            Case -9999 To -1
                Просрочено = _
                    Просрочено & _
                    Проект(i, 1) & ". " & _
                    (Chr(13)) & _
                    "Исполнитель: " & Исполнитель(i, 1) & ". " & _
                    (Chr(13)) & _
                    "Срок: " & ДатаВып(i, 1) & " г." & _
                    vbCrLf & vbCrLf
        End Select
    Next i
    'отображение всех напоминаний
    If Просрочено <> "" Then
        MsgBox Просрочено, vbCritical, "Просрочено"
    End If
End Sub

Sub setArray(ByRef arr As Variant, ByVal addr As String)
    ReDim arr(1 To wks.Range(addr).Rows.Count, 1)
    arr = wks.Range(addr).Value
End Sub

'CODE 1 Ставим флажок, если был одиночный щелчок по ячейке
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Range("A5:A20")) Is Nothing Then 'Если ячейка пересекается с указанным диапазоном, то
            Target.Font.Name = "Marlett"    'Назначаем ячейке шрифт
            If Target = vbNullString Then    'Если ячейка пуста, то
                Target = "a"     'заполняем её символом "а" (латиница)
            Else    'Иначе
                Target = vbNullString 'в ячейке пусто
            End If
            Target.Offset(0,1).Activate    '"отскакиваем" вправо на один столбец
        End If
   End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("Таблица1")) Is Nothing Then
        a = Target.Row
        b = Range("Таблица2").Row
        If b - a = 3 Then
            Rows(a + 1).Insert Shift:=xlDown
            Rows(a * 2 + 2).Insert Shift:=xlDown
        End If
    End If
End Sub

 'CODE 1 Ставим флажок, если был одиночный щелчок по ячейке
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Range("E6:E33")) Is Nothing Then 'Если ячейка пересекается с указанным диапазоном, то
            Target.Font.Name = "Marlett" 'Назначаем ячейке шрифт
            If Target = vbNullString Then 'Если ячейка пуста, то
                Target = "a" 'заполняем её символом "а" (латиница)
            Else 'Иначе
                Target = vbNullString 'в ячейке пусто
            End If
            Target.Offset(0, 1).Activate '"отскакиваем" вправо на один столбец
        End If


          If Not Intersect(Target, Range("E4")) Is Nothing Then
                With Target
                .Font.Name = "Wingdings"
                 .Font.Size = 28
                If .Value = Chr(111) Then
                .Value = Chr(254)
                Else
                .Value = Chr(111)
                End If
                .Offset(0, 1).Select
            End With
    End If
    
                If Target = "ю" Then 'Если ячейка пуста, то
                Range("E6:E33").Value = "a" 'заполняем диапазон символом "а" (латиница)
            Else 'Иначе
                Range("E6:E33").Value = vbNullString  'в ячейке пусто
            End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$G$1" Or Target.Address = "$I$1" Or Target.Address = "$K$1" Then
       If Range("N1").Value <> "" Then
             If Len(Range("N1").Value) < 30 Then
               Target.Parent.Name = Range("N1").Value
             End If
       End If
    End If
    
    Dim i As Integer, j As Integer
    For i = 1 To Sheets.Count - 1
        For j = i + 1 To Sheets.Count
            If UCase(Sheets(i).Name) > UCase(Sheets(j).Name) Then
                Sheets(j).Move before:=Sheets(i)
            End If
       Next j
    Next i
End Sub
 
Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
    Case 13
        With Sheets("!!!Оглавление").Range("Имена")
            If ComboBox2.ListIndex = -1 Then .Offset(.Rows.Count).Resize(1) = ComboBox2.Text
        End With
End Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 
If Target.Address = "$G$1" Or Target.Address ="$I$1" Or Target.Address = "$K$1" Then
If Range("N1").Value <>"" Then
If Len(Range("N1").Value) < 30 Then
Target.Parent.Name =
Range("N1").Value
End If
End I   
End If
       
Dim i As Integer, j As Integer   
For i = 1 To Sheets.Count - 1
        For j = i + 1 To Sheets.Count
            If UCase(Sheets(i).Name) >UCase(Sheets(j).Name) Then
                Sheets(j).Move before:=Sheets(i)
            End If
       Next j   
Next i
End Sub

=ЕСЛИ(ПРОВЕРКА;ГИПЕРССЫЛКА(ЛИСТ.СПИСОК&"'!A1";ЛИСТ.ИМЯ);"")