Dim Rng As Range, maxValue As Long  
Set Rng = Range("B3:B20000")
maxValue = Application.WorksheetFunction.Max(Rng)

Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
   
Dim arr As Variant
arr = Range("B1:B" & iLastRow).Value
Dim iCurRow As Long, curValue As Long
For iCurRow = 1 To UBound(arr, 1)
    If Not IsEmpty(arr(iCurRow, 1)) Then
        Dim strValue As String
        strValue = CStr(arr(iCurRow, 1))
        If Len(strValue) > 4 Then 
            
            Dim numberPart As String
            numberPart = Mid(strValue, 5)
            If IsNumeric(numberPart) Then
                curValue = CLng(numberPart)
                If maxValue < curValue Then maxValue = curValue
            End If
        ElseIf IsNumeric(strValue) Then 
            curValue = CLng(strValue)
            If maxValue < curValue Then maxValue = curValue
        End If
    End If
Next
   
Cells(iLastRow + 1, 2) = Left(Cells(iLastRow + 1, 3), 3) & Format(maxValue + 1, "_000000")

Sub Наполнение_данными()
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("Данные"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal1 As Worksheet: Set shCatal1 = GetSheet("ЗАКАЗЫ"): If shCatal1 Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
     
    With shCatal1
     
    Dim yc As Long
            yc = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            .Cells(yc, 3).Value = shMarsh.Range("A3").Value
            '.Cells(yc, 4).Value = shMarsh.Range("B3").Value
            '.Cells(yc, 5).Value = shMarsh.Range("C3").Value
            '.Cells(yc, 6).Value = shMarsh.Range("D3").Value
            '.Cells(yc, 7).Value = shMarsh.Range("E3").Value
            '.Cells(yc, 8).Value = shMarsh.Range("F3").Value
            '.Cells(yc, 9).Value = shMarsh.Range("G3").Value
            '.Cells(yc, 10).Value = shMarsh.Range("H3").Value
            '.Cells(yc, 11).Value = shMarsh.Range("I3").Value
            
            
            End With
                              
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range: Set Rng = [A1:V20000]
    If Not Intersect(Rng, Target) Is Nothing Then
    Application.ScreenUpdating = False

     Worksheets("ЗАКАЗЫ").Sort.SortFields.Clear
     Worksheets("ЗАКАЗЫ").Sort.SortFields.Add Key:=Range("A2:A20000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "отгружено,упаковано,в работе,в ожидании,заказ,аутсорс,подготовка ТС", DataOption:=xlSortNormal
     Worksheets("ЗАКАЗЫ").Sort.SortFields.Add Key:=Range("R2:R20000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
    With Worksheets("ЗАКАЗЫ").Sort
        .SetRange Range("A1:BC20000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    End If
    
    
    
End Sub

Cells(iLastRow + 1, 2) = Left(Cells(iLastRow + 1, 7), 3) & "_" & maxValue + 1

Cells(iLastRow + 1, 2) = Left(Cells(iLastRow + 1, 7), 3) & "_" & maxValue + 1

 Set Rng = Range("B3:B20000")
 maxValue = Application.WorksheetFunction.Max(Rng)
 
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
Cells(iLastRow + 1, 2) = maxValue + 1

Sub tt()Dim r As Range
Set r = Intersect(Selection, Range("B3:B" & Rows.Count))
f Not r Is Nothing Then r.Select
End Sub

Sub Трудоемкость()
Application.ScreenUpdating = False
If Selection.Address <> "$B3:$B20000" Then Exit Sub
Selection.Copy
Sheets("МАРШРУТ").Range("A7").PasteSpecial
With ActiveCell.EntireRow

            .Cells(1, 22).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G10:G14")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 23).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G16:G24")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 24).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G26:G40")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 25).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G42:G50")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 26).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G52:G59")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 27).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G61:G79")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 28).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G81:G113")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 29).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G115:G116")) * Sheets("МАРШРУТ").Range("A5") / 60
            .Cells(1, 30).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G118:G119")) * Sheets("МАРШРУТ").Range("A5") / 60
            
            End With
            End Sub

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

Application.ScreenUpdating = False

Selection.Copy
Sheets("МАРШРУТ").Range("A7").PasteSpecial

With ActiveCell.EntireRow
            .Cells(1, 23).Value = WorksheetFunction.Sum(Sheets("МАРШРУТ").Range("G16:G22")) * Sheets("МАРШРУТ").Range("A5") / 60
            
            End With
            
            End Sub