Сократить диапазон чисел, записав их через знак тире

Sub proba()
Dim I As Integer, Last As Integer, S As String, Chi() As Integer, Sc, L1 As Integer
Dim K As Integer, J As Integer, L As Integer, N As Integer, I1 As Integer
Last = Cells(Rows.Count, 1).End(xlUp).Row
For I = 2 To Last
  Sc = Split(Cells(I, 2), ","): K = UBound(Sc)
  L1 = -1
  For J = 0 To K
    L = InStr(Sc(J), "-")
    If L > 0 Then  'диапазон
      For I1 = CInt(Left(Sc(J), L - 1)) To CInt(Mid(Sc(J), L + 1))
        L1 = L1 + 1: ReDim Preserve Chi(L1): Chi(L1) = I1
      Next
    Else
      L1 = L1 + 1: ReDim Preserve Chi(L1): Chi(L1) = CInt(Sc(J))
    End If
  Next
  S = "": L = Chi(0): K = L
  ReDim Preserve Chi(L1 + 1): Chi(L1 + 1) = Chi(L1) + 5: L1 = L1 + 1
  For J = 1 To L1
    If Chi(J) <> L + 1 Then
      S = S & "," & K & IIf(L = K, "", IIf(K + 1 = L, ",", "-") & Chi(J - 1))
      L = Chi(J): K = L
    Else
      L = L + 1
    End If
  Next
  Cells(I, 5) = Mid(S, 2)
Next
End Sub

Function ConvrtStr(xStr)
  dim ii, i1, i2, i3, i4, aa, aaa, oStr
  aa = Split(xStr,",") 'разбиваем строку на массив подстрок по разделителю - запятая
  aaa = Split(aa(0),"-") ' разбиваем начальный элемент этого массива подстрок по разделителю - тире. 
  i1 = Cint(aaa(0)):  i2 = Cint(aaa(uBound(aaa))) 'первое число -> i1, последнее (если оно одно, то первое) -> i2
  oStr = Cstr(i1) ' запишем в результирующую строку пока самое первое число
  for ii= 1 to Ubound (aa) step 1 ' пробежимся по остальным элементам массива подстрок
    aaa = Split(aa(ii),"-") ' каждый разбиваем на массив полуподстрок - получаем 1 или 2 элемента
    i3 = Cint(aaa(0)):  i4 = Cint(aaa(uBound(aaa))) 'первое число -> i3, последнее (если оно одно - оно же и первое) -> i4
    If i3 = i2+1 Then ' Если это смежные диапазоны чисел 
      i2 = i4         ' - сольём их в один
    else              ' в противном случае дозаписываем хвост предыдущего диапазона
      if I2 = i1+1 Then oStr = oStr & "," & cstr(i2)  'если диапазон всего из 2 чисел
      if I2 > i1+1 Then oStr = oStr & "-" & cstr(i2)  'если диапазон поболее
      i1 = i3: i2 = i4 'текущий диапазон становится прежним
      oStr = oStr & "," & cstr(i1) 'Дозаписываем начало этого диапазона в результирующую строку 
    end if
  next
  if I2 = i1+1 Then oStr = oStr & "," & cstr(i2) 'дозаписываем хвост последнего диапазаноа
  if I2 > i1+1 Then oStr = oStr & "-" & cstr(i2) 
  Convrtstr = oStr ' результат возвращаем
end Function