Исправить код сжимания цифр - VBA

Формулировка задачи:

как исправить этот код сжимания чтобы 15-16, 20-21 не соединял, а только такие соединял 18-22, 25-27, то есть от трех и выше соединить, но не два вместе в столбце B, начиная с B2 и ниже при нажатии на кнопку Сжать не сжимало 1 2 9 10 в 1-2, 9-10...

Sub Sjim()
    Dim b(), i&, j&
    With Range("B2:B5000" & Cells(2, 1).End(xlDown))
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 1)
        j = 1
        For i = 1 To UBound(a, 1)
            If IsEmpty(a(i, 1)) Then Exit For
            If IsEmpty(b(j, 1)) Then b(j, 1) = a(i, 1)
            If i + 1 <= UBound(a, 1) Then
                If a(i + 1, 1) <> a(i, 1) + 1 Then
                    If b(j, 1) <> a(i, 1) Then b(j, 1) = "'" & b(j, 1) & "-" & a(i, 1)
                    j = j + 1
                End If
            End If
        Next
        .Value = b
    End With
End Sub

Решение задачи: «Исправить код сжимания цифр»

textual
                            Листинг программы 
                        

                            Function Sgatie(диапазон As Range) As String
    Dim i&, j&, a()
    a = диапазон.Value
    Dim tArr
    ReDim tArr(1 To UBound(a, 1), 1 To 3)
    For i = 1 To UBound(a, 1)
        tArr(i, 1) = a(i, 1)
        tArr(i, 2) = a(i, 1)
    Next
      
    Output = ""
    For i = 1 To UBound(a, 1)
        tArr(i, 1) = a(i, 1)
        tArr(i, 2) = a(i, 1)
        For y = i + 1 To UBound(tArr, 1)
            If tArr(i, 2) + 1 = tArr(y, 1) Then
                tArr(i, 2) = tArr(y, 1)
                tArr(y, 1) = 0
            Else
                i = y - 1: Exit For
            End If
        Next y
    Next i
      
    For i = 1 To UBound(tArr, 1)
        If tArr(i, 1) <> 0 Then
            If tArr(i, 1) = tArr(i, 2) Then
                Output = Output & tArr(i, 1) & ","
            ElseIf tArr(i, 1) = tArr(i, 2) - 1 Then
                Output = Output & tArr(i, 1) & ", " & tArr(i, 2) & ", "
            ElseIf tArr(i, 1) < tArr(i, 2) - 1 Then
                Output = Output & tArr(i, 1) & "-" & tArr(i, 2) & ", "
            Else
                MsgBox ("Ошибка в формуле")
            End If
        End If
    Next i
      
    If Right(Output, 1) = "," Then
        Output = Mid(Output, 1, Len(Output) - 1)
    End If
    Sgatie = Output
End Function
                        