Sub ExportNamedRangesToSheet()
    Dim ws As Worksheet
    Dim nName As Name
    Dim i As Integer
    Dim rng As Range
    Dim refersToValue As String

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("NamedRanges")
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add
        ws.Name = "NamedRanges"
    End If
    On Error GoTo 0

    ws.Cells.Clear

    ws.Cells(1, 1).Value = "Имя"
    ws.Cells(1, 2).Value = "Значение"
    ws.Cells(1, 3).Value = "Диапазон"
    ws.Cells(1, 4).Value = "Область"
    ws.Cells(1, 5).Value = "Примечание"

    totalNames = ThisWorkbook.Names.Count

    ' Заполняем таблицу именованными диапазонами
    i = 2
    currentIndex = 0 ' Счётчик для прогресса
    For Each nName In ThisWorkbook.Names
        currentIndex = currentIndex + 1 ' Обновляем прогресс

        Application.StatusBar = "Экспорт именованных диапазонов: " & currentIndex & " из " & totalNames & " (" & Format(currentIndex / totalNames, "0%") & ")"

        ws.Cells(i, 1).Value = nName.Name ' Имя

        On Error Resume Next
        refersToValue = "'" & nName.RefersTo ' Преобразуем в строку, добавляя апостроф для безопасности
        On Error GoTo 0

        If Len(refersToValue) > 0 Then
            ws.Cells(i, 2).Value = refersToValue
        Else
            ws.Cells(i, 2).Value = "" ' Оставляем пустым, если ошибка
        End If

        On Error Resume Next
        Set rng = Nothing
        Set rng = nName.RefersToRange
        On Error GoTo 0
        
        If Not rng Is Nothing Then
            ws.Cells(i, 3).Value = rng.Worksheet.Name & "!" & rng.Address ' Включаем имя листа
        Else
            ws.Cells(i, 3).Value = "Не применимо" ' Если это не диапазон
        End If

        ' Определяем, глобальный ли это диапазон или на уровне листа
        If nName.Parent Is ThisWorkbook Then
            ws.Cells(i, 4).Value = "Глобальный (Workbook)"
        Else
            ws.Cells(i, 4).Value = nName.Parent.Name ' Лист, если диапазон на уровне листа
        End If
        
        ws.Cells(i, 5).Value = "" ' Примечание
        i = i + 1
    Next nName

    Application.StatusBar = False

    MsgBox "Именованные диапазоны экспортированы на лист 'NamedRanges'.", vbInformation
End Sub

Sub UpdateNamedRangesFromSheet()
    Dim ws As Worksheet
    Dim nName As Name
    Dim lastRow As Long
    Dim i As Long
    Dim newRange As String
    Dim oldName As String
    Dim totalRows As Long
    Dim currentIndex As Long

    Set ws = ThisWorkbook.Sheets("NamedRanges")

    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    totalRows = lastRow - 1
    currentIndex = 0

    ' Проходим по каждому имени и обновляем диапазон (можно оставить только те строки которые необходимо изменить)
    For i = 2 To lastRow
        currentIndex = currentIndex + 1

        Application.StatusBar = "Обновление именованных диапазонов: " & currentIndex & " из " & totalRows & " (" & Format(currentIndex / totalRows, "0%") & ")"

        oldName = ws.Cells(i, 1).Value
        newRange = ws.Cells(i, 3).Value

        ' Ищем соответствующее имя и обновляем его
        For Each nName In ThisWorkbook.Names
            If nName.Name = oldName Then
                On Error Resume Next
                nName.RefersTo = "=" & newRange ' Обновляем диапазон
                On Error GoTo 0
                Exit For
            End If
        Next nName
    Next i

    Application.StatusBar = False

    MsgBox "Именованные диапазоны обновлены на основе изменений на листе.", vbInformation
End Sub