Dim aa As Long
        aa = ShtS.Cells(ShtS.Rows.Count, 1).End(xlUp).Row
        With ShtS.Range("$V$2", ShtS.Cells(aa, 22)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(И(W2=""дата"";V2<>"""");(V2>=СЕГОДНЯ())*(V2<=(СЕГОДНЯ()+10)))")
        .Interior.Color = vbYellow
        .StopIfTrue =

Dim lLastRow As Long
        lLastRow = ShtS.UsedRange.Row + ShtS.UsedRange.Rows.Count - 1
        With ShtS.Range("$V$2", ShtS.Cells(lLastRow, 22)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(И(W2=""дата"";V2<>"""");V2<СЕГОДНЯ())")
        .Interior.Color = vbRed
        .StopIfTrue = False
        End With

With ShtS.Range("$V$2", ShtS.Cells(ShtS.Rows.Count, 22).End(xlUp)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(И(W2=""дата"";V2<>"""");(V2>=СЕГОДНЯ())*(V2<=(СЕГОДНЯ()+10)))")
.Interior.Color = vbYellow
.StopIfTrue = False
End With

With ShtS.Range("$A$2", ShtS.Cells(ShtS.Rows.Count, 47).End(xlUp)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(($W2<>""дата"")*($W2<>"""");$W2<=СЕГОДНЯ())")
.Interior.Color = vbCyan
.StopIfTrue = False
End With

   ShtS.Cells.FormatConditions.Delete
        With ShtS.Range("AC2", Cells(Rows.Count, 4).End(xlUp)).FormatConditions.Add(xlExpression, , "=ЕСЛИ(ИЛИ($T2="";$T2=""Нет данных"";$T2=""На согласовании"");СЕГОДНЯ()-ПСТР(Y2;6;10);$T2-ПСТР(Y2;6;10))<=5")
        .Interior.Color = vbGreen
        .StopIfTrue = False
        End With

Sub format()  
With Range("D5", Cells(Rows.Count, 4).End(xlUp)).FormatConditions. _  
Add(xlExpression, , "=$E$2>($D5+30)")  
   .Interior.Color = vbRed  
'    .StopIfTrue = False  
End With  
End Sub

If .Cells (N:W) = "дата"
Then
вставляем формулу
Else
вставляем как значение
End If

Sub perenosSZ()

Dim ShtS As Worksheet
Dim ShtZ As Worksheet
Dim last_row As Integer
Dim last_row_other As Integer
Dim strg As String
Dim first_row As Integer
Dim rng As Range
Dim retZ As Integer
Dim retS As Integer

On Error Resume Next
Set ShtZ = Workbooks("База - ЗАКУПКИ.xlsx").Worksheets("БазаЗакупки")
Set ShtS = Workbooks("База - СНАБЖЕНИЕ.xlsx").Worksheets("БазаСнабжение")
'проверяем открыт ли файл для загрузки данных с всплывающим сообщением о необходимости выполнит действие
    If ShtZ Is Nothing Then
        retZ = MsgBox("ВНИМАНИЕ! Откройте файл База - ЗАКУПКИ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
    Exit Sub
    End If
    If ShtS Is Nothing Then
        retS = MsgBox("ВНИМАНИЕ! Откройте файл База - СНАБЖЕНИЕ.xlsx", vbExclamation + vbOKCancel, "Внимание!!!")
    Exit Sub
    End If
On Error GoTo 0
'----------------------
    If ShtZ.AutoFilterMode = True Then ShtZ.Cells.AutoFilter ' отключает все фильтры если они включены
    If ShtS.AutoFilterMode = True Then ShtS.Cells.AutoFilter ' отключает все фильтры если они включены
    ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
    ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2 'отключает групировку второго уровня "разгруппировать"
    Application.ScreenUpdating = False 'отключаем обновление экрана
    Application.Calculation = xlCalculationManual 'отключаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = False 'отключаем отслеживание событий
    If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1 'переключает отображения стиля ссылок "R1C1" --> "A1"
    
last_row = ShtS.Cells(Rows.Count, 1).End(xlUp).Row
last_row_other = ShtZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
strg = "Заключение договора"
For first_row = last_row To 1 Step -1
    If InStr(1, strg, ShtS.Cells(first_row, 32).Value) > 0 Then 'Условие отбора строк по "статусу заявки""
            
            ShtZ.Range("A2:AU2").Copy
            ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
            'ShtZ.Range("A2:AU2").Copy ShtZ.Range("A" & last_row_other & ":AU" & last_row_other) 'копируем формат 2-й строки базы закупок и применяем к новым строкам
            ShtZ.Range("A" & last_row_other & ":AU" & last_row_other).Value = ShtS.Range("A" & first_row & ":AU" & first_row).Value 'вставляет строку соответствующую критериям
        If ShtZ.Range("Y" & last_row_other).Value = "" Then ShtZ.Range("Y" & last_row_other).Value = "С->З " & Date Else ShtZ.Range("Y" & last_row_other).Value = ShtZ.Range("Y" & last_row_other).Value & ", С->З " & Date ' вставляет текущую дату в ячейку Y в строке соответствующую критериям
            
            If Not rng Is Nothing Then 'проверяем создан ли диапазон для накопления строк
                Set rng = Union(rng, ShtS.Rows(first_row)) 'накапливаем в диапазоне строки для удаления
            Else
                Set rng = ShtS.Rows(first_row) 'создаём диапазон для накопления строк для удаления
            End If
            
            last_row_other = last_row_other + 1
    End If
Next

If Not rng Is Nothing Then rng.Delete Shift:=xlUp 'удаляем строки в накопленном диапазоне

    If ShtZ.AutoFilterMode = False Then ShtZ.Cells.AutoFilter ' включает все фильтра если они отключены
    If ShtS.AutoFilterMode = False Then ShtS.Cells.AutoFilter ' включает все фильтра если они отключены
    ShtZ.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
    ShtS.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1 'включает групировку первого уровня "группировать"
    Application.ScreenUpdating = True 'включаем обновление экрана
    Application.Calculation = xlCalculationAutomatic 'включаем автоматический пересчёт формул после каждого действия с листом
    Application.EnableEvents = True 'включаем отслеживание событий
    
    MsgBox "ВЫПОЛНЕНО!", vbInformation
    
End Sub