Sub SetReadOnlyAttribute()
    Dim fso As Object
    Dim file As Object
    ' Создаем объект FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    ' Путь к файлу
    Dim filePath As String
    filePath = ThisWorkbook.Path & Application.PathSeparator & "Апрель.xlsx"  'тут имя файла измените на свое
     
    ' Проверяем, существует ли файл
    If fso.FileExists(filePath) Then
        ' Получаем объект файла
        Set file = fso.GetFile(filePath)
         
        ' Устанавливаем атрибут "Только чтение"
        file.Attributes = file.Attributes Or ReadOnlyAttribute
         
        MsgBox "Атрибут 'Только чтение' установлен для файла: " & filePath
    Else
        MsgBox "Файл не найден: " & filePath
    End If
     
    ' Очищаем объекты
    Set file = Nothing
    Set fso = Nothing
End Sub

Sub elruso()
Dim arr()
Dim iCl As Range
Dim I&
With ActiveSheet
  arr = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
  For I = 3 To .Cells(.Rows.Count, "B").End(xlUp).Row Step 3
    N = N + 1
    .Range("A" & I) = .Range("A" & I) & ", " & arr(N, 1)
  Next
End With
End Sub

Sub SelectCells()
Dim lRow&
Dim iCl As Range
Dim iRng As Range
On Error Resume Next
With ActiveSheet
  lRow = .Cells(.Rows.Count, "D").End(xlUp).Row
  lRow = IIf(lRow < 3, 3, lRow)
  For Each iCl In .Range("D3:D" & lRow).Cells
    If Not IsEmpty(iCl) Then
      If Not iRng Is Nothing Then
        Set iRng = Union(iRng, iCl.Offset(, 1))
      Else
        Set iRng = iCl.Offset(, 1)
      End If
    End If
  Next
  If Not iRng Is Nothing Then iRng.Select
End With
End Sub