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

Автор Наталья Бублик, 11.04.2014, 11:40

« назад - далее »

Наталья Бублик

Добрый день.
Есть задача,например есть ряд чисел 600063,   600064,   600065,   600066,   600067,   600068,   600069,   600070,   600071,   600072
Мне нужно собрать эти числа в диапазон 600063-600069, 600070-600072
или 600063-600072
С помощью какого макроса или какой функции это можно сделать,а главное как?
СПасибо

cheshiki1


Наталья Бублик


cheshiki1

Private Sub LiteSort(ByRef x())
Dim v, u&, d&, f%
If IsArray(x) Then
    f = LBound(x): d = f
    For u = f + 1 To UBound(x)
        If x(u) < x(d) Then
            v = x(d): x(d) = x(u): x(u) = v
            u = d - 1: d = u - 1: If u < f Then d = u: u = f
        End If
        d = d + 1
    Next
End If
End Sub


Sub Example()
Dim x()
Dim c As Variant, M&, i&, r&
For Each c In Sheets("Лист2").Range("A1").CurrentRegion
M = M + 1
ReDim Preserve x(1 To M)
x(M) = c.Value
Next
LiteSort x()
r = 1
With Sheets("Лист1")
.Cells(r, 1) = x(1)
For i = 2 To UBound(x)
If x(i - 1) + 1 <> x(i) Then
.Cells(r, 1) = .Cells(r, 1) & " - " & x(i - 1)
r = r + 1
.Cells(r, 1) = x(i)
End If
Next
.Cells(r, 1) = .Cells(r, 1) & " - " & x(i - 1)
End With
End Sub

запускаем макрос "Example" список появляется на лист1

Наталья Бублик

#4
Я разобралась,у меня получилось!Спасибо вам большое.
Только если инфа в файле выглядит по другому,он не работает,правильно я понимаю?
Файл приложила

cheshiki1

для Чудо2 работать не будет. вы правы. у вас два варианта данных или вы просто интересуетесь?

Наталья Бублик

У меня вариантов очень много,но я не буду наглеть,если поможете со вторым чудом,буду премного благодарна!

cheshiki1

#7
Private Sub LiteSort(ByRef x())
Dim v, u&, d&, f%
If IsArray(x) Then
    f = LBound(x): d = f
    For u = f + 1 To UBound(x)
        If x(u) < x(d) Then
            v = x(d): x(d) = x(u): x(u) = v
            u = d - 1: d = u - 1: If u < f Then d = u: u = f
        End If
        d = d + 1
    Next
End If
End Sub


Sub Example1()
Dim x()
Dim c As Variant, M&, i&, r&
Dim Ms As Variant
Ms = Split([A1], ",")
For c = 0 To UBound(Ms)
M = M + 1
ReDim Preserve x(1 To M)
x(M) = --Ms(c)
Next
LiteSort x()
r = 1
With Sheets("Лист1")
.Cells(r, 1) = x(1)
For i = 2 To UBound(x)
If x(i - 1) + 1 <> x(i) Then
.Cells(r, 1) = .Cells(r, 1) & " - " & x(i - 1)
r = r + 1
.Cells(r, 1) = x(i)
End If
Next
.Cells(r, 1) = .Cells(r, 1) & " - " & x(i - 1)
End With
End Sub

значения в ячейке должны заканчиваться числом, а не запятой.