Запись цифр, которые содержатся в одном столбце через дефис и запятую

[OLEG02711]

Sub SetNums()
Dim r1 As Long, r2 As Long, r As Long, c1 As Long, c2 As Long
r1 = 1: r2 = 6: c1 = 1: c2 = 9: Cells(r2, c2 + 1).NumberFormat = "@"
Cells(r2, c2) = Cells(r1, c1): Cells(r2, c2 + 1) = Cells(r1, c1 + 1)
Do
r = 1
Do While Cells(r1 + r, c1 + 1) - Cells(r1 + r - 1, c1 + 1) = 1 And Cells(r1, c1) = Cells(r1 + r, c1)
r = r + 1
If Cells(r1, c1) <> Cells(r1 + r, c1) Then Exit Do
Loop
If r > 1 Then Cells(r2, c2 + 1) = Cells(r2, c2 + 1) & IIf(r > 2, "-", ", ") & Cells(r1 + r - 1, c1 + 1)
If Cells(r1, c1) <> Cells(r1 + r, c1) Then
r2 = r2 + 1: Cells(r2, c2 + 1).NumberFormat = "@"
Cells(r2, c2) = Cells(r1 + r, c1): Cells(r2, c2 + 1) = Cells(r1 + r, c1 + 1)
Else
Cells(r2, c2 + 1) = Cells(r2, c2 + 1) & ", " & Cells(r1 + r, c1 + 1)
End If
r1 = r1 + r
Loop Until Cells(r1, c1) = ""
End Sub