If Application.WorksheetFunction.CountA(Sh.Range("B" & LastRow & ":G" & LastRow)) > 0 Then

Option Explicit
Dim IsChanged_2026  As Boolean

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name <> "2026" Then Exit Sub
    If Intersect(Target, Sh.Range("B:G")) Is Nothing Then Exit Sub

    IsChanged_2026 = True
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If Not IsChanged_2026 Then Exit Sub
    Dim Sh          As Worksheet

    Dim wsExists    As Boolean
    wsExists = False

    For Each Sh In ThisWorkbook.Worksheets

        If Sh.Name = "2026" Then
            wsExists = True
            Exit For
        End If

    Next Sh

    If Not wsExists Then Exit Sub

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim UserName    As String
    UserName = CreateObject("WScript.Network").UserName

    Dim SaveTime    As String
    SaveTime = Format(Now, "dd.mm.yyyy HH:mm:ss")

    With ThisWorkbook.Worksheets("2026")

        Dim f       As Range
        Set f = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

        If Not f Is Nothing Then

            Dim LastRow As Long
            LastRow = f.Row

            If Application.WorksheetFunction.CountA(.Range("B" & LastRow & ":G" & LastRow)) > 0 Then
                .Cells(LastRow, "P").Value = UserName
                .Cells(LastRow, "Q").Value = SaveTime
            End If
        
        End If

    End With

    MsgBox "Файл сохранен!" & vbCrLf & _
            "Пользователь: " & UserName & vbCrLf & _
            "Время: " & SaveTime, vbInformation
    IsChanged_2026 = False

    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Option Explicit
Dim ChangedRows_2026 As Object

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name <> "2026" Then Exit Sub
    If Intersect(Target, Sh.Range("B:G")) Is Nothing Then Exit Sub
    Dim cell        As Range

    If ChangedRows_2026 Is Nothing Then
        Set ChangedRows_2026 = CreateObject("Scripting.Dictionary")
    End If

    For Each cell In Target.Cells

        If Not ChangedRows_2026.exists(cell.Row) Then
            ChangedRows_2026.Add cell.Row, True
        End If

    Next cell

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If ChangedRows_2026 Is Nothing Then Exit Sub
    If ChangedRows_2026.Count = 0 Then Exit Sub

    Dim ws          As Worksheet
    Dim exists      As Boolean

    For Each ws In ThisWorkbook.Worksheets

        If ws.Name = "2026" Then
            exists = True
            Exit For
        End If

    Next ws

    If Not exists Then Exit Sub

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim UserName    As String
    Dim SaveTime    As String

    UserName = CreateObject("WScript.Network").UserName
    SaveTime = Format(Now, "dd.mm.yyyy HH:mm:ss")

    Dim key         As Variant

    With ThisWorkbook.Worksheets("2026")

        For Each key In ChangedRows_2026.Keys

            If Application.WorksheetFunction.CountA(.Range("B" & key & ":G" & key)) > 0 Then
                .Cells(key, "P").Value = UserName
                .Cells(key, "Q").Value = SaveTime
            End If

        Next key

    End With

    MsgBox "Сохранено!" & vbCrLf & _
            "Пользователь: " & UserName & vbCrLf & _
            "Строк изменено: " & ChangedRows_2026.Count, vbInformation
    Set ChangedRows_2026 = Nothing

    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

' Процедура добавления примечания об изменении значения
Sub AddCommentForValueChange(cell As Range, user As String, timeStr As String, oldVal As Variant)
    Dim commentText As String
' Формируем текст примечания в зависимости от типа изменения
    If cell.Address = OldAddress Then
' Если изменилось значение в той же ячейке
        commentText = user & " (" & timeStr & "): " & _
                     "изменил '" & oldVal & "' на '" & cell.Value & "'"
    Else
' Если это новая ячейка
        commentText = user & " (" & timeStr & "): " & _
                     "установил '" & cell.Value & "'"
    End If
' Добавляем или обновляем примечание
    AddOrUpdateComment cell, commentText
End Sub