=И(СЕГОДНЯ();НЕ(ЕОШИБКА(ПОИСКПОЗ(B4;ДВССЫЛ("Дата[Данные]");0))))

Sub num()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim lr&
lr = Cells(Rows.Count, 2).End(xlUp).Row
lr = IIf(lr < 5, 5, lr)
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).ClearContents
For i = 5 To lr
 If Application.WorksheetFunction.CountA(Rows(i)) <> 0 Then
  K = K + 1
 Cells(i, 1) = K
End If
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sub Sort1()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim Sh As Range, iLastRow&
iLastRow& = Cells(ActiveWorkbook.Worksheets("Ëèñò1").Rows.Count, 8).End(xlUp).Row
iLastRow& = IIf(iLastRow < 5, 5, iLastRow)
    ActiveWorkbook.Worksheets("Ëèñò1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Ëèñò1").Sort.SortFields.Add Key:=Range("D5:D" & iLastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Ëèñò1").Sort
        .SetRange Range("B5:H" & iLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sub Sort2()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim Sh As Range, iLastRow&
iLastRow& = Cells(ActiveWorkbook.Worksheets("Ëèñò2").Rows.Count, 9).End(xlUp).Row
iLastRow& = IIf(iLastRow < 5, 5, iLastRow)
    ActiveWorkbook.Worksheets("Ëèñò2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Ëèñò2").Sort.SortFields.Add Key:=Range("D5:D" & iLastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Ëèñò2").Sort
        .SetRange Range("B5:I" & iLastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

=ЕСЛИ(РАЗНДАТ(C6;D8;"ym")=0;"";РАЗНДАТ(C6+1;D8;"ym")&" мес. ")&ЕСЛИ(D8-C6=0;"Сегодня";ЕСЛИ(РАЗНДАТ(C6;D8-1;"md")<0;"";РАЗНДАТ(C6;D8-1;"md")&" дн."))

=ЕСЛИ(ЕПУСТО(C5);"";ВЫБОР(ЗНАК(ДАТА(ГОД(ТДАТА());МЕСЯЦ(C5);ДЕНЬ(C5))-СЕГОДНЯ())+2;ДАТА(ГОД(ТДАТА())+1;МЕСЯЦ(C5);ДЕНЬ(C5))-СЕГОДНЯ()&" дн.";"Сегодня";ДАТА(ГОД(ТДАТА());МЕСЯЦ(C5);ДЕНЬ(C5))-СЕГОДНЯ()&" дн."))

Private Sub UserForm_Initialize()
Dim i As Long, j As Long
    For i = 7 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(i, 1).Font.Color = RGB(255, 0, 0) Then
           ListBox1.AddItem i
           ListBox1.List(j, 1) = Cells(i, 1)
           j = j + 1
        End If
    Next
End Sub

Private Sub ListBox1_Click()
    If ListBox1.ListIndex = -1 Then Exit Sub
    Cells(ListBox1.Value, 1).Select
End Sub

Private Sub ListBox1_Change()
      ListBox1.Clear

   j = 0
   
      For i = 7 To Cells(Rows.Count, 1).End(xlUp).Row
          If Cells(i, 1).Font.Color = RGB(255, 0, 0) Then
             ListBox1.AddItem i
             ListBox1.List(j, 1) = Cells(i, 1)
             j = j + 1
          End If
      Next
      Exit Sub
   End If

End Sub

Private Sub ListBox1_Click()
    If ListBox1.ListIndex = -1 Then Exit Sub
    Cells(ListBox1.Value, 1).Select
End Sub

Sub List1()
Dim uniq As New Collection
Dim iLastRow As Long
Dim i As Long
Dim Arr()
iLastRow = Cells(Rows.Count, 3).End(xlUp).Row
iLastRow = IIf(iLastRow < 10, 10, iLastRow)
    For i = 10 To iLastRow
        On Error Resume Next
        uniq.Add Cells(i, 3), CStr(Cells(i, 3))
    Next
ReDim Arr(1 To uniq.Count)
    For i = 1 To uniq.Count
        Arr(i) = uniq(i)
    Next i

With Cells(9, 3).Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:=Join(Arr, ",")
    .IgnoreBlank = True
    .InCellDropdown = True
    .ShowInput = True
    .ShowError = False
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
If Not Intersect(Target, Range("C4:D4")) Is Nothing Then
   Worksheets(1).Unprotect Password:="1"
End If

If Intersect(Target, Range("C4:D4")) Is Nothing Then
   Worksheets(1).Protect Password:="1", UserInterfaceOnly:=True, _
   AllowFormattingCells:=True, AllowFormattingColumns:=True, _
   AllowFormattingRows:=True, AllowFiltering:=True
End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    g = Target.Row
    If Cells(g, 3).Resize(, 3).Value > 0 Then
        Intersect([F:F], Target.EntireRow).Value = Now
    Else
        Intersect([F:F], Target.EntireRow).Value = Empty
    End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [C4:F20]) Is Nothing Then
  If Cells(Target.Row, Target.Column) = 0 Then
    Cells(Target.Row, Target.Column).Font.Color = RGB(0, 0, 0)
  End If
End If

End Sub

Sub iCopyr()
Dim a&, b&, c&
For a = 1 To 5
  c = Cells(Rows.Count, a + 1).End(xlUp).Row
  c = IIf(c < 4, 4, c + 1)
  If c > b Then b = c
Next

If Len([C2] & [D2] & [E2]) > 0 Then
  Cells(b, 3).Resize(, 4).Value = [C2:F2].Value
End If

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

If Len([B2]) > 0 Then
  [B2].Select
  SendKeys ("^k")
End If

End Sub

Sub ListB()
Dim uniq As New Collection
Dim iLastCol As Long
Dim i As Long
Dim Arr()
iLastCol = Cells(2, Columns.Count).End(xlToLeft).Column
iLastCol = IIf(iLastCol < 4, 4, iLastCol)
Debug.Print iLastCol
    For i = 4 To iLastCol
        On Error Resume Next
        uniq.Add Cells(2, i), CStr(Cells(2, i))
    Next
ReDim Arr(1 To uniq.Count)
    For i = 1 To uniq.Count
        Arr(i) = uniq(i)
    Next i
With Cells(2, 2).Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:=Join(Arr, ",")
    .IgnoreBlank = True
    .InCellDropdown = True
    .ShowInput = True
    .ShowError = False
End With
End Sub

Range("B5:E8").Rows.AutoFit
Range("B5:E8").Rows.WrapText = True

Sub iCol()
Application.EnableEvents = False

Dim iRng As Range, iAddr$
If Len([E2]) > 0 Then
  With Range("C7:E" & ActiveSheet.UsedRange.Rows.Count)
    Range("C7:E" & ActiveSheet.UsedRange.Rows.Count).Font.Color = RGB(0, 0, 0)
    Set iRng = .Find([E2], After:=.Cells(.Cells.Count), LookIn:=xlValues)
    If Not iRng Is Nothing And Len([E2]) > 0 Then
        iAddr = iRng.Address
        Do
            iRng.Font.Color = RGB(218, 16, 16)
            Set iRng = .FindNext(iRng)
        Loop While Not iRng Is Nothing And iRng.Address <> iAddr
    End If
    End With
End If
If Len([E2]) = 0 Then
 Range("C7:E" & ActiveSheet.UsedRange.Rows.Count).Font.Color = RGB(0, 0, 0)
End If

Application.EnableEvents = True

End Sub

Sub Макрос2()
'
' Макрос2 Макрос

    Range("B6:F14").Select
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("B6:B14"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").Sort
        .SetRange Range("B6:F14")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
End Sub

Sub Fill()
Application.ScreenUpdating = False
If [E2] <> 0 Then
Dim SRow&
Dim SRowD&
Dim SRowE&
SRow = Cells(Rows.Count, 3).End(xlUp).Row
SRowD = Cells(Rows.Count, 4).End(xlUp).Row
SRowE = Cells(Rows.Count, 5).End(xlUp).Row
If SRow < SRowD Then SRow = SRowD
If SRow < SRowE Then SRow = SRowE
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).ClearContents
SRow = IIf(SRow < 7, 7, SRow)
 If SRow > 7 Then
    Range("A7").FormulaArray = "=--ISNA(MATCH(999,SEARCH(R2C5,RC[2]:RC[4]),1))"
    Range("A7").Copy: Range("A8:A" & SRow).PasteSpecial Paste:=xlPasteFormulas
 End If
    Application.CutCopyMode = False
    [E2].Select
Else
    Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).ClearContents
End If
    Application.ScreenUpdating = True
End Sub

Sub DeleteEmptyRows()
    Dim r As Long, rng As Range
    For r = 1 To ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
        If Application.CountA(Rows(r)) = 0 Then
            If rng Is Nothing Then Set rng = Rows(r) Else Set rng = Union(rng, Rows(r))
        End If
        Debug.Print r
    Next r
    If Not rng Is Nothing Then rng.Delete
    ActiveWorkbook.Save
End Sub

Set rowvalue = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
r = rowvalue.Row

Option Explicit
 
Sub Col()
    Dim i As Long
    With [C7:F20]
        For i = 1 To .Rows.Count Step 2
            .Rows(i).Interior.Color = RGB(189, 215, 238)
        Next i
    End With
End Sub

Sub List()
Dim uniq As New Collection
Dim iLastRow As Long
Dim i As Long
Dim arr()
iLastRow = Cells(Rows.Count, 3).End(xlUp).Row
iLastRow = IIf(iLastRow < 7, 7, iLastRow)
    For i = 7 To iLastRow
        On Error Resume Next
        uniq.Add Cells(i, 3), CStr(Cells(i, 3))
    Next
ReDim arr(1 To uniq.Count)
    For i = 1 To uniq.Count
        arr(i) = uniq(i)
    Next i
Cells(3, 3).Validation.Delete
Cells(3, 3).Validation.Add Type:=xlValidateList, Formula1:=Join(arr, ",")
End Sub