' в начале кода
Склад.Range("A:D").FormatConditions.Delete

' в конце кода
Склад.Range("A:D").FormatConditions.Add Type:=xlExpression, Formula1:="=$A1 = "">"""
    Склад.Range("A:D").FormatConditions(Склад.Range("A:D").FormatConditions.count).SetFirstPriority
    Склад.Range("A:D").FormatConditions(1).Borders(xlLeft).LineStyle = xlNone
    Склад.Range("A:D").FormatConditions(1).Borders(xlRight).LineStyle = xlNone
    Склад.Range("A:D").FormatConditions(1).Borders(xlTop).LineStyle = xlNone
    Склад.Range("A:D").FormatConditions(1).Borders(xlBottom).LineStyle = xlNone
    With Склад.Range("A:D").FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
    End With
    Склад.Range("A:D").FormatConditions(1).StopIfTrue = False

Private Sub переместитьвверх_Click()

    
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim endRow As Long
    Dim selectedIndex As Long
    
    selectedIndex = список.ListIndex
    If selectedIndex <= 0 Then Exit Sub
    

    For i = 1 To Склад.Cells(Rows.count, "A").End(xlUp).row
        If Склад.Cells(i, "A") = ">" Then
            selectedIndex = selectedIndex - 1
            If selectedIndex < 0 Then Exit For
        End If
    Next i
    

    If i > 1 Then

        endRow = i + 1
        Do While endRow <= Склад.Cells(Rows.count, "A").End(xlUp).row And Склад.Cells(endRow, "A") <> ">"
            endRow = endRow + 1
        Loop
        endRow = endRow - 1
        

        j = i - 1
        Do While j > 1 And Склад.Cells(j, "A") <> ">"
            j = j - 1
        Loop
        

        For k = i To endRow
            Склад.Rows(k).Cut
            Склад.Rows(j).Insert Shift:=xlDown
            j = j + 1
        Next k
    End If


    UpdateList
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False ' Отключаем обработку событий
    For Each cell In Target
If Target.Cells.Count = 1 Then
            If Not Intersect(cell, Range("F2:F10000")) Is Nothing Then ' Должники
            
                If Target.Column = 6 And (Target.Value = "Наличка" Or Target.Value = "Карта") And cell.Offset(0, -5) > 0 Then
                    Target.CurrentRegion.Rows(Target.Row).Cut
                    Cells(Rows.Count, 2).End(xlUp).Offset(1, -1).Select
                    ActiveCell.Insert Shift:=xlDown
                    cell.Offset(0, -3).Value = Time
                    cell.Offset(0, -4).Value = Date
                    cell.Offset(0, -5).Value = ""
                Else
                    Dim PosLedN As Long
                    Dim ids As Long
                    PosLedN = Cells(Rows.Count, "F").End(xlUp).Row
                    For ids = PosLedN To 2 Step -1
                        If Cells(ids, "F") = "Долг" Then
                            Cells(ids, "A").Value = ids
                        Else
                            Cells(ids, "A").Value = ""
                        End If
                    Next ids
                End If
            End If
        End If
    next cell
End Sub

      If Not Intersect(cell, Range("F2:F10000")) Is Nothing Then ' Должники
          If cell.Offset(0, 0) = "Долг" Then
                With cell.Offset(0, -5)
                    .Value = ActiveCell.Row
                End With
            Else
                If Target.Cells.Count = 1 Then
                    If Target.Column = 6 And (Target.Value = "Наличка" Or Target.Value = "Карта") And cell.Offset(0, -5) > 0 Then
                        arr1 = Target.CurrentRegion.Rows(Target.Row)
                        Cells(Rows.Count, 2).End(xlUp).Offset(1, -1).Resize(, UBound(arr1, 2)) = arr1
                        Target.EntireRow.Delete
                    End If
                End If
            End If
        End If

    If Intersect(Target, Range("G2:G10000")) Is Nothing Then Exit Sub
    
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("G2:G10000"))
        If IsEmpty(cell) Then
            NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки
        Else
            NewCellValue = cell.Formula     'или ее содержимое
            
        End If
        On Error Resume Next
        If NewCellValue = "Ячейка очищена" Then
        Else
            With cell.Offset(0, -3)
                OldComment = .Comment.Text & Chr(10)
                .Comment.Delete     'удаляем старое примечание (если было)
                .AddComment         'добавляем новое и вводим в него текст
                .Comment.Text Text:=OldComment & " " & _
                              Format(Now, "DD.MM.YYYY") & ": " & NewCellValue
                .Comment.Shape.TextFrame.AutoSize = True    'делаем автоподбор размера
                .Comment.Shape.TextFrame.Characters.Font.Size = 8
            End With
            Target.Value = ""
        End If
    Next cell

Private Sub Workbook_Open()
    If Day(Date) < 5 Then
        If SheetExist(ThisWorkbook.Name, Format(Date - 5, "MM.YYYY")) Then
        Else
            Application.Run "Лист4" & "." & "DelStariyMechyac"
        End If
    End If

End Sub

Function SheetExist(WbName As String, ShName As String) As Boolean
Dim mySheet As Worksheet
    For Each mySheet In Workbooks(WbName).Sheets
        If mySheet.Name = ShName Then
            SheetExist = True
            Exit Function
        End If
    Next
End Function

Private Sub Workbook_Open()
   
    Dim Дата As Date
    Dim lr As Long, i As Long
   
   
    ' Отключение монитора, чтобы ускорить макрос.
    Application.ScreenUpdating = False
   
    '1. Здесь укажите количество дней.
        ' Более 30 дней.
    tmpdat = Date - 30
   
    '2. Поиск последней строки в столбце B.
        ' End не ищет в скрытых строках.
    lr = Cells(Rows.Count, "B").End(xlUp).Row
   
    '3. Удаление строк.
    For i = lr To 1 Step -1
        If Cells(i, "B").Value < tmpdat Then
            Rows(i).Delete
        End If
    Next i
   
    '4. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub