Sub test()
    Dim a, i As Long, temp, x, result
    a = Range("a1").CurrentRegion.Value
    ReDim Preserve a(1 To UBound(a, 1), 1 To 5)
    For i = 1 To UBound(a, 1)
        temp = CheckPattern(a(i, 1))
        x = Split(temp, "|")
        If UBound(x) = 1 Then
            a(i, 2) = x(0)
            a(i, 3) = x(1)
            a(i, 5) = a(i, 1)
        Else
            a(i, 2) = x(0)
            a(i, 3) = x(1)
            a(i, 4) = x(2)
            a(i, 5) = x(0) & x(1)
        End If
    Next
    x = GetGrouped(a)
    x = GetSeries(x(0), x(1), 100)
    result = GetAligned(a, x)
    Application.ScreenUpdating = False
    For i = 1 To UBound(result, 1)
        If result(i, 1) = "" Then Rows(i).Insert
    Next
    Range("a1").Resize(UBound(result, 1), 2).Value = result
    Application.ScreenUpdating = True
End Sub
 
 
Private Function CheckPattern(ByVal txt As String) As String
    Dim Fnum, Lnum
    With CreateObject("VBScript.RegExp")
        .Pattern = "^(\D+)(\d+)$"
        .IgnoreCase = True
        If .test(txt) Then
            CheckPattern = .Replace(txt, "$1|$2")
        Else
            .Pattern = "^(\D+)(\d+) ?\-(.*\D)?(\d+)$"
            If .test(txt) Then
                Fnum = .Replace(txt, "$2")
                Lnum = .Replace(txt, "$4")
                If Len(Fnum) <> Len(Lnum) Then
                    Lnum = Application.Replace(Fnum _
                    , Len(Fnum) - Len(Lnum) + 1, Len(Fnum), Lnum)
                End If
                CheckPattern = .Replace(txt, "$1|") & Fnum & "|" & Lnum
            Else
                .Pattern = "^(\D+)(\d+) DEN (\d+) .*$"
                If .test(txt) Then
                    Fnum = .Replace(txt, "$2")
                    Lnum = .Replace(txt, "$3")
                    If Len(Fnum) <> Len(Lnum) Then
                        Lnum = Application.Replace(Fnum _
                        , Len(Fnum) - Len(Lnum) + 1, Len(Fnum), Lnum)
                    End If
                    CheckPattern = .Replace(txt, "$1|") & Fnum & "|" & Lnum
                End If
            End If
        End If
    End With
End Function
 
 
 
 
Private Function GetGrouped(a As Variant) As Variant
    Dim i As Long, w(), myNum
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 2)) Then
                ReDim w(1 To 4, 1 To 1)
                w(1, 1) = a(i, 3)
                w(2, 1) = IIf(a(i, 4) = "", a(i, 3), a(i, 4))
                w(3, 1) = a(i, 3)
                .Item(a(i, 2)) = w
            Else
                w = .Item(a(i, 2))
                ReDim Preserve w(1 To 4, 1 To UBound(w, 2) + 1)
                w(1, UBound(w, 2)) = a(i, 3)
                w(2, UBound(w, 2)) = IIf(a(i, 4) = "", a(i, 3), a(i, 4))
                w(3, UBound(w, 2)) = _
                w(2, UBound(w, 2)) - Val(w(1, UBound(w, 2) - 1))
                .Item(a(i, 2)) = w
            End If
        Next
        GetGrouped = VBA.Array(.keys, .items)
    End With
End Function
 
 
Function GetSeries(x, y, myLimit)
    Dim i As Long, ii As Long, iii As Long
    With CreateObject("System.Collections.ArrayList")
        For i = LBound(x) To UBound(x)
            If UBound(y(i), 2) = 1 Then
                For iii = y(i)(1, 1) To y(i)(2, 1)
                    .Add x(i) & iii
                Next
            Else
                .Add x(i) & y(i)(1, 1)
                For ii = 2 To UBound(y(i), 2)
                    If y(i)(2, ii) > y(i)(2, ii - 1) And y(i)(3, ii) < myLimit Then
                        For iii = y(i)(2, ii - 1) + 1 To y(i)(2, ii)
                            .Add x(i) & iii
                        Next
                    Else
                        .Add x(i) & y(i)(1, ii)
                    End If
                Next
            End If
        Next
        GetSeries = .ToArray
    End With
End Function
 
 
Function GetAligned(p, x)
    Dim i As Long, temp
    ReDim a(1 To UBound(x) + 1, 1 To 2)
    With CreateObject("Scripting.Dictionary")
        For i = 0 To UBound(x)
            .Item(x(i)) = i + 1
            a(i + 1, 2) = x(i)
        Next
        For i = 1 To UBound(p, 1)
            temp = p(i, 2) & p(i, 3)
            If .exists(temp) Then a(.Item(temp), 1) = p(i, 1)
        Next
        GetAligned = a
    End With
End Function