Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range
    If Not Intersect(Target, Range("C16,C17,C19,C20,C23,C24,C25,C27")) Is Nothing Then
        Set Rng = Range("H16,H17,H19,H20,H23,H24,H25,H27")
        Application.EnableEvents = False
        Rng.Value = Target.Value
    End If
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C16,C17,C19,C20,C23,C24,C25,C27")) Is Nothing Then
        Dim targetRow As Long
        targetRow = Target.Row
        
        Application.EnableEvents = False
        Range("H" & targetRow).Value = Target.Value
        Application.EnableEvents = True
    End If
End Sub

Sub Трудоемкость()

    Application.ScreenUpdating = False

    Dim cell As Range
    Dim ws As Worksheet
    
    ' Указываем явно рабочий лист "МАРШРУТ"
    Set ws = Sheets("МАРШРУТ")
    
    ' Проверяем, есть ли выделенные ячейки
    If Selection Is Nothing Then
        MsgBox "Ошибка: Нет выделенных ячеек."
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' Проверяем, что все выделенные ячейки находятся в диапазоне B3:B
    For Each cell In Selection
        If Intersect(cell, ws.Range("B3:B" & ws.Rows.Count)) Is Nothing Then
            MsgBox "Ошибка: Выделенные ячейки должны быть в диапазоне B3:B."
            Application.ScreenUpdating = True
            Exit Sub
        End If
    Next cell

    ' Копирование выделенных ячеек
    Selection.Copy
    
    ' Вставка в ячейку A7 на листе "МАРШРУТ"
    ws.Range("A7").PasteSpecial Paste:=xlPasteValues
    
    ' Проверяем, что ActiveCell находится на рабочем листе
    If Not Intersect(ActiveCell, ws.UsedRange) Is Nothing Then
        ' Выполняем расчет для 22-й ячейки строки с ActiveCell
        With ActiveCell.EntireRow
            .Cells(1, 22).Value = WorksheetFunction.Sum(ws.Range("G10:G14")) * ws.Range("A5") / 60
        End With
    Else
        MsgBox "Ошибка: Неверная активная ячейка."
        Application.ScreenUpdating = True
        Exit Sub
    End If

    Application.ScreenUpdating = True
    MsgBox "Операция выполнена успешно."
    
End Sub

Function ExtractDNPN(text As String) As String
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    Dim result As String
    
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True
    regex.Pattern = "\b(DN\d+|PN\d+)\b"
    
    Set matches = regex.Execute(text)
    
    For Each match In matches
        result = result & match.Value & " "
    Next match
    
    ExtractDNPN = Trim(result)
End Function

=ExtractDNPN(B2) 

Sub Трудоемкость()

Application.ScreenUpdating = False

' Переменные для проверки
Dim cell As Range
Dim found As Boolean

' Проверяем наличие текста "проверить каталог!" в диапазоне B3:B
found = False
For Each cell In Sheets("МАРШРУТ").Range("B3:B" & Rows.Count)
    If cell.Value = "проверить каталог!" Then
        found = True
        Exit For ' Останавливаем цикл, если найдено совпадение
    End If
Next cell

If found Then
    MsgBox "Ошибка: В диапазоне B3:B найдена ячейка с текстом 'проверить каталог!'."
    Exit Sub
End If

' Проверяем, что выделение находится в диапазоне B3:B
For Each cell In Selection
    If Not Intersect(cell, Sheets("МАРШРУТ").Range("B3:B" & Rows.Count)) Is Nothing Then
        ' Если ячейка в диапазоне, продолжаем выполнение
    Else
        MsgBox "Ошибка: Выделенная область должна быть в диапазоне B3:B."
        Exit Sub
    End If
Next cell

' Копирование выделенной области и вставка на листе "МАРШРУТ"
Selection.Copy
Sheets("МАРШРУТ").Range("A7").PasteSpecial

' Вычисление значения на основе диапазона G16:G22 и ячейки A5
With ActiveCell.EntireRow
    .Cells(1, 23).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G16:G22")) * Sheets("МАРШРУТ").Range("A5") / 60
End With

Application.ScreenUpdating = True

End Sub

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

Sub UpdateNamedRanges()
    Dim nName As Name
    Dim oldAddress As String
    Dim newAddress As String
    
    For Each nName In ThisWorkbook.Names
        oldAddress = nName.RefersTo
        
        If InStr(1, oldAddress, "$EB$", vbTextCompare) > 0 Then
            newAddress = Replace(oldAddress, "$EB$", "$EC$")
            
            nName.RefersTo = newAddress
            
            Debug.Print "Имя: " & nName.Name & " изменено с " & oldAddress & " на " & newAddress
        End If
    Next nName

    MsgBox "Обновление диапазонов завершено!", vbInformation
End Sub

Sub UpdateNamedRangesWithProgressBar()
    Dim nName As Name
    Dim oldAddress As String
    Dim newAddress As String
    Dim totalNames As Long
    Dim currentIndex As Long
    Dim searchValue As String
    Dim replaceValue As String
    Dim activeWorkbook As Workbook

    Set activeWorkbook = Application.ActiveWorkbook

    searchValue = InputBox("Введите значение, которое нужно заменить (например, $EB$):", "Значение для замены")
    If searchValue = "" Then Exit Sub ' Отмена, если ничего не введено

    replaceValue = InputBox("Введите новое значение, на которое нужно заменить (например, $EC$):", "Новое значение")
    If replaceValue = "" Then Exit Sub ' Отмена, если ничего не введено

    totalNames = activeWorkbook.Names.Count
    currentIndex = 0

    'прогресс-бар
    Set ProgressForm = VBA.UserForms.Add("ProgressForm")
    ProgressForm.ProgressBar.Width = 0
    ProgressForm.ProgressLabel.Caption = "Обновление диапазонов..."
    ProgressForm.Show vbModeless

    For Each nName In activeWorkbook.Names
        currentIndex = currentIndex + 1
        UpdateProgressBar currentIndex, totalNames
        oldAddress = nName.RefersTo

    ' Проверяем, содержит ли диапазон искомое значение и меняем его на новое
        If InStr(1, oldAddress, searchValue, vbTextCompare) > 0 Then
            newAddress = Replace(oldAddress, searchValue, replaceValue)

            nName.RefersTo = newAddress

            Debug.Print "Имя: " & nName.Name & " изменено с " & oldAddress & " на " & newAddress
        End If
    Next nName

    ' Закрываем форму прогресс-бара после завершения
    Unload ProgressForm
    MsgBox "Обновление диапазонов завершено!", vbInformation
End Sub

Sub UpdateProgressBar(currentIndex As Long, totalNames As Long)
    ' Обновление ширины прогресс-бара и текста на форме
    If Not ProgressForm Is Nothing Then
        With ProgressForm
            .ProgressBar.Width = (.ProgressFrame.Width - 2) * (currentIndex / totalNames)
            .ProgressLabel.Caption = "Обновление: " & currentIndex & " из " & totalNames & _
                                     " (" & Format(currentIndex / totalNames, "0%") & ")"
            DoEvents ' Обновление интерфейса
        End With
    End If
End Sub