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

[Viktorkv]

Здравствуйте!

Помогите решить задачу посредством макроса в EXCEL 2003.
В столбце "A" содержатся названия уровня, в столбце "B" номера.

Задача проанализировать эти два столбца и если номера повторяются написать их через дефис, если нарушается непрерывность счета, то через запятую. Результат обработки помещается в столбцы I и J.

[IgorGO]

через тире записываются 3 и более чисел подряд (2 подряд будут разделены запятыми)

Sub SetNums()
  Dim r1 As Long, r2 As Long, r As Long, c1 As Long, c2 As Long
  r1 = 2: 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, c1 + 1) = r
      r = r + 1
      If Cells(r1, c1) <> Cells(r1 + r, c1) Then Exit Do
    Loop
    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

[Viktorkv]

Если цифры будут идти в таком порядке:

А 1
А 2
А 3
А 4
А 5
А 7

получится

А 1-5, 7, 7, 28-38, 64-69, 90-109, 156-166, 175-179

[IgorGO]

эту строку

Cells(r2, c2 + 1) = Cells(r2, c2 + 1) & IIf(r > 2, "-", ", ") & Cells(r1 + r - 1, c1 + 1)

запишите так

If r > 1 Then Cells(r2, c2 + 1) = Cells(r2, c2 + 1) & IIf(r > 2, "-", ", ") & Cells(r1 + r - 1, c1 + 1)

[Viktorkv]

IgorGO, спасибо огромное!

[Viktorkv]

IgorGO, в чем может быть причина, почему функция выдает "-"
Public Function Тире_запятая(Диапазон As Range, Символ)
Dim M(), R, T
With Диапазон
M = Range(.Cells(1, 1), .Cells(Cells(Rows.Count, 1).End(xlUp).Row, 2))
End With
For R = 2 To LR
If M(R, 1) = Символ Then
If Len(Тире_запятая) = 0 Then
Тире_запятая = M(R, 2)
Else
If M(R, 2) <> T + 1 Then
Тире_запятая = Тире_запятая & "-" & T & ", " & M(R, 2)
End If
End If
T = M(R, 2)
End If
Next R
Тире_запятая = Тире_запятая & "-" & T
End Function

[ikki_pf]

просто интересно: Viktorkv, Вы заблудились в созданных Вами темах?
функцию Тире_запятая Вам написал другой человек.
и на другом форуме.

[IgorGO]

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
    Loop
    Cells(r2, c2 + 1) = Cells(r2, c2 + 1) & IIf(r > 1, "-" & Cells(r1 + r - 1, c1 + 1), "") & ", " & Cells(r1 + r, c1 + 1)
    If Cells(r1, c1) <> Cells(r1 + r, c1) Then
      Cells(r2, c2 + 1) = Left(Cells(r2, c2 + 1), Len(Cells(r2, c2 + 1)) - Len(", " & Cells(r1 + r, c1 + 1))): r2 = r2 + 1
      Cells(r2, c2 + 1).NumberFormat = "@":  Cells(r2, c2) = Cells(r1 + r, c1): Cells(r2, c2 + 1) = Cells(r1 + r, c1 + 1)
    End If
    r1 = r1 + r
  Loop Until Cells(r1, c1) = ""
End Sub

[Viktorkv]

IgorGO, последний макрос выдает ошибку type mismatch

Ничего страшного, предыдущий все правильно делает, спасибо за помощь!

[IgorGO]

ошибка наверное в этой строке

Do While Cells(r1 + r, c1 + 1) - Cells(r1 + r - 1, c1 + 1) = 1 And Cells(r1, c1) = Cells(r1 + r, c1)

и наверное потому, что в строке
r1 = 1: r2 = 6: c1 = 1: c2 = 9
r1 = 1 а не 2 как было в начальном варианте (стартовая строка ссылается мимо данных)

упростил логику на несколько строк и попутно изменилось правило работы: через тире отбображаются любые подряд идущие номера. например: 1 2 5 7 8 9 10
в последнем варианте будет отображено как:
1-2, 5, 7-10

а в предыдущей версии так:
1, 2, 5, 7-10