Sub u_623()
    Application.ScreenUpdating = False
    ssa = Cells(Rows.Count, "a").End(xlUp).Row
    If ssa = 1 Then ssa = 2
    For Each c In Range("a2:a" & ssa)
        aa = c.Value
        If c <> "" Then
            ab = Replace(Replace(aa, ",", ";"), " ", "") & ";"
            ac = Len(ab) - Len(Replace(ab, ";", ""))
            s = ""
            q = ""
            For i = 1 To ac
                ca = InStr(ab, ";")
                cb = Left(ab, ca - 1)
                cc = InStr(cb, "-")
                cb_ = --Mid(ab, ca - 3, 3)
                If cc > 0 Then
                    g_min = Mid(cb, cc - 3, 3)
                    g_max = Right(cb, 3)
                    g_tex = Left(cb, cc - 4)
                    g_klv = g_max - g_min + 1
                    For j = 1 To g_klv
                        x = g_tex & Right("00" & g_min + j - 1, 3)
                        t = ","""
                        If s = "" Then t = """"
                        s = s & t & x & """" 'ar1
                        u = ","
                        If q = "" Then u = ""
                        q = q & u & g_min + j - 1 'ar2
                    Next
                Else
                    t = ","""
                    If s = "" Then t = """"
                    s = s & t & cb & """" 'ar1
                    u = ","
                    If q = "" Then u = ""
                    q = q & u & cb_ 'ar2
                End If
                ab = Mid(ab, ca + 1, Len(ab))
            Next
            la = Len(q) - Len(Replace(q, ",", "")) + 1
            k = ""
            For l = 1 To la
                lb = Evaluate("=SMALL({" & q & "}," & l & ")")
                lc = Evaluate("=MATCH(" & lb & ",{" & q & "},0)")
                ld = Evaluate("=INDEX({" & s & "}," & lc & ")")
                y = "; "
                If k = "" Then y = ""
                k = k & y & ld
            Next
            c.Offset(0, 1) = k
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Public Function Разбивка(ByRef rng As Range)
Dim n, m, s As String, x As String, y As Integer, y1 As Integer
On Error GoTo ErrHand
Set re = CreateObject("VBScript.RegExp")
Set dic = CreateObject("Scripting.Dictionary")
re.Global = True: re.Pattern = "\d+"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
arr1 = Split(s, ";")
For Each n In arr1
    arr2 = Split(n, "-")
    x = re.Replace(arr2(0), "")
    If Not dic.Exists(x) Then Set dic(x) = CreateObject("System.Collections.ArrayList")
    y = CInt(Replace(arr2(0), x, ""))
    If UBound(arr2) > 0 Then y1 = CInt(Replace(arr2(1), x, "")) Else y1 = y
    For m = y To y1
        If Not dic(x).contains(m) Then dic(x).Add m
    Next m
Next n
s = ""
For Each n In dic
    dic(n).Sort
    For Each m In dic(n)
        s = s & "; " & n & Format(m, "0##") 'dic(n).Item
    Next
Next
Разбивка = Mid(s, 3)
Exit Function
ErrHand:
Разбивка = "Ошибка"
End Function

Public Function Разбивка(ByRef rng As Range)
Dim n, m, s As String, x As String, y As Integer, y1 As Integer
On Error GoTo ErrHand
Set re = CreateObject("VBScript.RegExp")
Set dic = CreateObject("System.Collections.SortedList")
re.Global = True: re.Pattern = "(\d+)$"
s = Replace(Replace(rng.Value, ",", ";"), " ", "")
arr1 = Split(s, ";")
For Each n In arr1
If n <> "" Then
    If re.Test(n) Then
        arr2 = Split(n, "-")
        x = re.Replace(arr2(0), "")
        If Not dic.Contains(x) Then Set dic(x) = CreateObject("Scripting.Dictionary")
        y = CInt(Replace(arr2(0), x, ""))
        i = Len(Replace(arr2(0), x, ""))
        If UBound(arr2) > 0 Then y1 = CInt(Replace(arr2(1), x, "")) Else y1 = y
        For m = y To y1
            If Not dic(x).Exists(CStr(m)) Then dic(x).Add CStr(m), i
        Next m
    Else
        i = Len(n)
        If Not dic.Contains(n) Then Set dic(n) = CreateObject("Scripting.Dictionary")
        If Not dic(n).Exists(CStr(n)) Then dic(n).Add CStr(n), -1
    End If
End If
Next n
s = ""
For n = 0 To dic.Count - 1
    For Each m In dic(dic.GetKey(n))
        If dic(dic.GetKey(n)).Item(m) > 0 Then
            If CInt(dic(dic.GetKey(n)).Item(m)) - Len(m) > 0 Then
                s = s & "; " & dic.GetKey(n) & String(dic(dic.GetKey(n)).Item(m) - Len(m), "0") & m
            Else
                s = s & "; " & dic.GetKey(n) & m
            End If
        Else
            s = s & "; " & m
        End If
    Next
Next
Разбивка = Mid(s, 3)
Exit Function
ErrHand:
Разбивка = "Ошибка"
End Function