Option Explicit
' =============================================================================
' Функция: РАСПИСАТЬ
' Описание: Раскрывает сокращённые записи номеров (например, "1...5" в "1, 2, 3, 4, 5")
' Параметры:
'   - номера: диапазон ячеек с номерами
'   - строка: опционально - индекс для возврата конкретного элемента
' Возвращает: массив номеров или конкретный элемент по индексу
' =============================================================================
Function РАСПИСАТЬ(номера As Range, Optional строка As Long) As Variant
    РАСПИСАТЬ = ProcessNumbersWithNames(номера, Nothing, строка)
End Function
' =============================================================================
' Функция: РАСПИСАТЬНАИМЕНОВАНИЯ
' Описание: Раскрывает сокращённые записи номеров и связывает их с наименованиями
' Параметры:
'   - номера: диапазон ячеек с номерами
'   - наименования: диапазон ячеек с наименованиями (должен совпадать по размеру)
'   - строка: опционально - индекс для возврата конкретной строки
' Возвращает: двумерный массив {номер, наименование} или конкретная строка
' =============================================================================
Function РАСПИСАТЬНАИМЕНОВАНИЯ(номера As Range, наименования As Range, Optional строка As Long) As Variant
    Set наименования = наименования.Cells(1, 1).Resize(номера.Rows.Count, номера.Columns.Count)
    РАСПИСАТЬНАИМЕНОВАНИЯ = ProcessNumbersWithNames(номера, наименования, строка)
End Function

Private Function ProcessNumbersWithNames(номера As Range, наименования As Range, Optional строка As Long) As Variant
    Dim xa As Long
    If наименования Is Nothing Then
        xa = 0
    Else
        xa = 1
    End If
    
    Dim result As Variant
    result = GetNumbersArray(GetValueFromRange(номера), GetValueFromRange(наименования))
    result = EditNumbersArray(result)
    result = GetOneSizeArray(result, xa)
    If xa = 0 Then
        result = CLngArray(result)
    End If
    If строка >= LBound(result, 1) Then
        If строка <= UBound(result, 1) Then
            ProcessNumbersWithNames = result(строка, 1)
        End If
    Else
        ProcessNumbersWithNames = result
    End If
End Function

Private Function CLngArray(arr As Variant) As Variant
    Dim ya As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        If IsNumeric(arr(ya, 1)) Then
            arr(ya, 1) = CLng(arr(ya, 1))
        End If
    Next
    CLngArray = arr
End Function

Private Function GetOneSizeArray(ByVal arr As Variant, xa As Long) As Variant
    Dim ya As Long, brr As Variant, yb As Long, va As Variant
    For ya = LBound(arr) To UBound(arr)
        arr(ya)(0) = Split(arr(ya)(0), ", ")
        yb = yb + (UBound(arr(ya)(0)) - LBound(arr(ya)(0)) + 1)
    Next
    If yb = 0 Then Exit Function
    ReDim brr(1 To yb, 1 To 1)
    yb = 0
    For ya = LBound(arr) To UBound(arr)
        For Each va In arr(ya)(0)
            yb = yb + 1
            If xa = 0 Then
                brr(yb, 1) = va
            Else
                brr(yb, 1) = arr(ya)(xa)
            End If
        Next
    Next
    GetOneSizeArray = brr
End Function

Private Function EditNumbersArray(ByVal arr As Variant) As Variant
    Dim ya As Long
    For ya = LBound(arr) To UBound(arr)
        If InStr(arr(ya)(0), ". ..") > 0 Then
            arr(ya)(0) = Replace(arr(ya)(0), ". ..", "...")
        End If
        If InStr(arr(ya)(0), "...") > 0 Then
            arr(ya)(0) = SplitString(arr(ya)(0))
        End If
    Next
    EditNumbersArray = arr
End Function

Private Function SplitString(ByVal source As String) As String
    Dim arr As Variant, ya As Long
    arr = Split(source, ", ")
    For ya = LBound(arr) To UBound(arr)
        If InStr(arr(ya), "...") > 0 Then
            arr(ya) = SplitValue(arr(ya))
        End If
    Next
    SplitString = Join(arr, ", ")
End Function

Private Function SplitValue(ByVal source As String) As String
    Dim arr As Variant, ya As Long
    arr = Split(source, "...")
    
    Dim iMin As Long, iMax As Long, flagNumeric As Boolean
    If IsNumeric(arr(0)) And IsNumeric(arr(1)) Then
        iMin = CLng(arr(0))
        iMax = CLng(arr(1))
        If iMin > iMax Then
            iMin = iMax
            iMax = CLng(arr(0))
        End If
        flagNumeric = True
    Else
        iMin = Asc(arr(0))
        iMax = Asc(arr(1))
        If iMin > iMax Then
            iMin = iMax
            iMax = Asc(arr(0))
        End If
    End If
    
    Dim brr As Variant, yb As Long
    ReDim brr(iMin To iMax) As String
    If flagNumeric Then
        For yb = iMin To iMax
            brr(yb) = yb
        Next
    Else
        For yb = iMin To iMax
            brr(yb) = Chr(yb)
        Next
    End If
    SplitValue = Join(brr, ", ")
End Function

Private Function GetNumbersArray(arr As Variant, nrr As Variant) As Variant
    If IsEmpty(nrr) Then ReDim nrr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
    Dim yb As Long, ya As Long, xa As Long
    ReDim brr(1 To UBound(arr, 1) * UBound(arr, 2))
    For xa = 1 To UBound(arr, 2)
        For ya = 1 To UBound(arr, 1)
            If arr(ya, xa) <> "" Then
                yb = yb + 1
                brr(yb) = Array(arr(ya, xa), nrr(ya, xa))
            End If
        Next
    Next
    If yb = 0 Then Exit Function
    If yb < UBound(brr) Then ReDim Preserve brr(LBound(brr) To yb)
    GetNumbersArray = brr
End Function

Private Function GetValueFromRange(rr As Range) As Variant
    If rr Is Nothing Then Exit Function
    Set rr = Intersect(rr, rr.Parent.UsedRange)
    
    Dim arr As Variant
    If rr.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    GetValueFromRange = arr
End Function