Sub FileSave(Name As String, N As Long)
    Dim IniFile ' полный путь для файла настроек
    Dim MyFile 'Объявляем переменную для свободного файла
    IniFile = NewFolderArh & Application.PathSeparator & "\" & "Set.ini"
    MyFile = FreeFile ' Присваиваем свободный канал, для работы с файлами
    Open (IniFile) For Output As #MyFile 'Открываем файл TEST.TXT для записи
    Print #MyFile, Name '' имя листа
    Print #MyFile, N '' имя листа
    Print #MyFile, Environ("username") '' имя последнего пользователя
    Close #MyFile 'Закрываем файл
End Sub
 
Function FileRead(Name As String, N As Long)
'' чтение файла
Dim NameSheet As String
Dim fN As Long
Dim UserName As String
Dim IniFile ' полный путь для файла настроек
Dim MyFile 'Объявляем переменную для свободного файла
Dim S As String 'Переменная для хранения считанных данных
FileRead = 0
    
    IniFile = NewFolderArh & Application.PathSeparator & "\" & "Set.ini"
    MyFile = FreeFile ' Присваиваем свободный канал, для работы с файлами
    On Error Resume Next                    ' обработка ошибки открытия файла
    Open (IniFile) For Input As #MyFile 'Открываем файл TEST.TXT для чтения
    If Err Then
 '       FileRead = 0
        Exit Function
    End If
   
    Line Input #MyFile, S 'Считываем первую строку из файла TEST.TXT в переменную S
    NameSheet = S
    Line Input #MyFile, S 'Считываем первую строку из файла TEST.TXT в переменную S
    fN = S
    Line Input #MyFile, S 'Считываем первую строку из файла TEST.TXT в переменную S
    UserName = S
    Close #MyFile 'Закрываем файл
    
    If Environ("username") <> UserName then
        If Name = NameSheet   Then
            If N <= fN Then
                MsgBox "Внимание! Строку " & N & " уже редактирует " & UserName
                FileRead = fN
            End If
        End If
    End If
End Function
Function UserStatus()
Dim NameUser As String
Dim CountUsers As Integer
CountUsers = 0
  'Свойство UserStatus Property возвращает 2D-массив (1 to 3), содержащий информацию _
   о каждом пользователе, открывшем книгу в режиме общего доступа.
  '1-й столбец - имя пользователя, открывшего книгу в режиме общего доступа, _
   2-й столбец - дата и время, когда этот пользователь открыл книгу, _
   3-й столбец - индикатор режима открытия книги (1 - монопольный, 2 - общий доступ).
   Users = ActiveWorkbook.UserStatus
        For Row = 1 To UBound(Users, 1)
            If Len(Users(Row, 1)) > 0 And NameUser <> Users(Row, 1) Then
                NameUser = Users(Row, 1)
                CountUsers = CountUsers + 1
            End If
        Next
   UserStatus = CountUsers
'   UserStatus = 2
End Function
Sub ZapNow()
Dim lRow As Long
Dim Xst As Integer
    ActiveSheet.Cells(2, 3).Select
    'Найти последнюю не пустую ячейку в столбце А(1)
    lRow = Cells(Rows.Count, 3).End(xlUp).Row + 1
    If Len(Cells(lRow, 3)) > 0 Then Exit Sub ' проверка, вдруг в этой строке что то есть
    
    If UserStatus > 1 Then ' с книгой работают больше одного пользователя
        Load FormMessage
        FormMessage.Show (0)
        DoEvents
        ' сохраним книгу, это обновит данные
        On Error Resume Next
        ThisWorkbook.Save
         ' проверим, нет ли к этой ячейке конфликтного доступа
        Xst = FileRead(ActiveSheet.Name, lRow)
        If Xst <> 0 Then
            lRow = Xst + 1
        End If
        Unload FormMessage
    End If
   
    Cells(lRow, 2) = Format(Now(), "dd.mm.yyyy")
    Cells(lRow, 1) = Environ("USERNAME")
    ' сохраним в файл метку наше присутствие
    FileSave ActiveSheet.Name, lRow
    Cells(lRow, 3).Select
    X = ActivateKeyboardLayout&(kb_lay_ru, 0) ' переключает раскладку на Русский язык. Если нет функции, убрать эту строку
 End Sub

Function NewFolderArh() As String
   NewFolderArh = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Архивные копи") '' тут называем папку куда складывать
    On Error Resume Next
    MkDir NewFolderArh
End Function

Sheets("Главная").Protect Password:="1234", UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFiltering:=True, DrawingObjects:=False 

Sheets("Главная").Protect Password:="1234", UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFiltering:=True, DrawingObjects:=False