Sub NewMacros()

    Dim Start!:           Start = Timer

    iCol = 3
    f = 300
    
    MyArr1 = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1)).Value
    ReDim MyArr2(LBound(MyArr1) To UBound(MyArr1))

    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 101 And jk <= 306 Then MyArr2(i) = f: f = f + 1
    Next i
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 401 And jk <= 606 Then MyArr2(i) = f: f = f + 1
    Next i
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 701 And jk <= 906 Then MyArr2(i) = f: f = f + 1
    Next i
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 1001 And jk <= 1306 Then MyArr2(i) = f: f = f + 1
    Next i
        
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 1401 And jk <= 1606 Then MyArr2(i) = f: f = f + 1
    Next i
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 1701 And jk <= 1906 Then MyArr2(i) = f: f = f + 1
    Next i
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 2001 And jk <= 2306 Then MyArr2(i) = f: f = f + 1
    Next i
        
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 2401 And jk <= 2606 Then MyArr2(i) = f: f = f + 1
    Next i
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 2701 And jk <= 2906 Then MyArr2(i) = f: f = f + 1
    Next i
    For i = LBound(MyArr1) To UBound(MyArr1)
        jk = Int(Right(MyArr1(i, 1), 4))
        If jk >= 3001 Then MyArr2(i) = f: f = f + 1
    Next i
    Cells(2, iCol).Resize(UBound(MyArr1)) = Application.Transpose(MyArr2)

    Debug.Print "Затрачено: " & Format(Timer - Start, "#0.00") & " сек."
End Sub

Sub NumGroup()
Dim aNum(), aMax(1 To 10)
Dim i As Long, k As Long
Const NumStart As Long = 300
    i = Cells(Rows.Count, 1).End(xlUp).Row
    aNum = Range("A1:A" & i).Value
    aNum(1, 1) = "номер"
    
    ' обрезаем номер и считаем количесто значений в каждом диапазоне
    For i = 2 To UBound(aNum)
        aNum(i, 1) = Val(Right(aNum(i, 1), 4))
        
        Select Case aNum(i, 1)
        Case Is >= 3001:
        Case Is >= 2701: aMax(9) = aMax(9) + 1
        Case Is >= 2401: aMax(8) = aMax(8) + 1
        Case Is >= 2001: aMax(7) = aMax(7) + 1
        Case Is >= 1701: aMax(6) = aMax(6) + 1
        Case Is >= 1401: aMax(5) = aMax(5) + 1
        Case Is >= 1001: aMax(4) = aMax(4) + 1
        Case Is >= 701: aMax(3) = aMax(3) + 1
        Case Is >= 401: aMax(2) = aMax(2) + 1
        Case Is >= 101: aMax(1) = aMax(1) + 1
        End Select
    Next i
    
    ' записываем начальные номера каждого диапазона
    For i = 10 To 2 Step -1
        aMax(i) = 0
    
        For k = i - 1 To 1 Step -1
            aMax(i) = aMax(i) + aMax(k)
        Next k
        
        aMax(i) = aMax(i) + NumStart
    Next i
    
    aMax(1) = NumStart
    
    ' нумеруем и увеличиваем номера каждого диапазона
    For i = 2 To UBound(aNum)
        Select Case aNum(i, 1)
        Case Is >= 3001: k = 10
        Case Is >= 2701: k = 9
        Case Is >= 2401: k = 8
        Case Is >= 2001: k = 7
        Case Is >= 1701: k = 6
        Case Is >= 1401: k = 5
        Case Is >= 1001: k = 4
        Case Is >= 701: k = 3
        Case Is >= 401: k = 2
        Case Is >= 101: k = 1
        End Select
        
        aNum(i, 1) = aMax(k): aMax(k) = aMax(k) + 1
    Next i
    
    Range("B1:B" & UBound(aNum)).Value = aNum
    MsgBox "OK", 64, ""
End Sub