Sub BlockRedFontCells()
    Dim ws As Worksheet
    Dim cell As Range
    Dim today As Date
    Dim twoDaysAgo As Date
    Dim lastRow As Long
    Dim rowRange As Range
    
    ' Устанавливаем рабочий лист
    Set ws = ThisWorkbook.Sheets("База")
    
    ' Получаем текущую дату
    today = Date
    twoDaysAgo = today - 2
    
    ' Находим последнюю непустую ячейку в столбце A
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' Сначала разблокируем все ячейки
    ws.Unprotect Password:="ваш_пароль" ' Установите свой пароль
    ws.Cells.Locked = False
    
    ' Проходим по диапазону A2 до последней непустой ячейки
    For Each cell In ws.Range("A2:A" & lastRow)
        ' Проверяем, если дата в ячейке меньше двух суток от сегодняшней
        If Not IsEmpty(cell) Then
            If cell.Value <= twoDaysAgo Then
                ' Определяем диапазон всей строки
                Set rowRange = ws.Range(cell, cell.Offset(0, 9)) ' A:J
                
                ' Меняем цвет шрифта на темно-красный для всей строки
                rowRange.Font.Color = RGB(139, 0, 0) ' Темно-красный цвет
                
                ' Блокируем всю строку, если шрифт красный
                If rowRange.Font.Color = RGB(139, 0, 0) Then
                    rowRange.Locked = True
                End If
            End If
        End If
    Next cell
    
    ' Защита листа
    ws.Protect Password:="ваш_пароль" ' Установите свой пароль
End Sub