Function comprsStr(sourceElements As String, Optional prefix As String, Optional separatorCells As String, Optional separatorRngs As String) As String
'Const defaultCellsSep  As String = ", "
Dim defaultCellsSep  As String: defaultCellsSep = ", "
'Const defaultRngsSep As String = "-"
Dim defaultRngsSep  As String: defaultRngsSep = "-"
Dim aElements As Variant
Dim aValues As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
    comprsStr = "?" ' Результат для ошибочного набора параметров или какой-то ошибки по ходу вычислений
    If IsMissing(separatorCells) Then
        separatorCells = defaultCellsSep
    End If
    If IsMissing(separatorRngs) Then
        separatorRngs = defaultRngsSep
    End If
    aElements = Split(sourceElements, separatorCells)
    If LBound(aElements) = UBound(aElements) Then ' Всего один элемент? Или не правильный сепаратор...
        comprsStr = Trim(sourceElements)
        Exit Function
    End If
    If IsMissing(prefix) Then
        prefix = ""
        For i = 1 To Len(aElements(0))
            If InStr("0123456789", Mid(aElements(0), i, 1)) > 0 Then Exit For
            prefix = prefix + Mid(aElements(0), i, 1)
        Next i
    End If
    ReDim aValues(UBound(aElements))
'    aValues = DimArray(UBound(aElements))
    For i = LBound(aElements) To UBound(aElements)
        aValues(i) = Val(Join(Split(aElements(i), prefix), ""))
    Next i
    Dim aSeries() As Long
    ReDim aSeries(UBound(aElements))
'Dim aSeries(UBound(aElements)) As Long
    n = 1
    aSeries(0) = n
    For i = LBound(aElements) + 1 To UBound(aElements)
        If aValues(i) - aValues(i - 1) <> 1 Then n = n + 1 ' Не просто "больше", а "не равно" - порядок сортировки мы не проверяли
        aSeries(i) = n
    Next i
    If n >= (UBound(aElements) / 2) Then ' Нет ни одной серии больше двух элементов подряд
        comprsStr = Trim(sourceElements)
        Exit Function
    End If
    Dim aCounts() As Long
    ReDim aCounts(n)
'Dim aCounts(n) As Long

    For i = LBound(aElements) To UBound(aElements)
        aCounts(aSeries(i)) = aCounts(aSeries(i)) + 1
    Next i
Rem Собираем данные для результата
Dim aRes() As String
ReDim aRes(UBound(aElements))
'Dim aRes(UBound(aElements)) As String
    i = 0
    j = 0
    For k = 1 To n
        If aCounts(k) = 1 Then
            aRes(j) = aElements(i)
            i = i + 1
            j = j + 1
        ElseIf aCounts(k) = 2 Then