Всем доброго времени суток. Столкнулся со следующей задачей, и что то случился затык... (решений обратной задачи много но вот этой так и не нашёл) Имеется некий ряд чисел (без разницы в столбик или в строку), отсортированных по возрастанию Например: 1 2 3 5 7 9 10 11 а необходимо поучить строку вида: 1-3, 5, 7, 9-11 Интересно бы посмотреть решение как формулами, так и на VBA Заранее спасибо.
Всем доброго времени суток. Столкнулся со следующей задачей, и что то случился затык... (решений обратной задачи много но вот этой так и не нашёл) Имеется некий ряд чисел (без разницы в столбик или в строку), отсортированных по возрастанию Например: 1 2 3 5 7 9 10 11 а необходимо поучить строку вида: 1-3, 5, 7, 9-11 Интересно бы посмотреть решение как формулами, так и на VBA Заранее спасибо.and_evg
Function u_4(u As Range) a = u.Count e = "" For b = 2 To a If u(b + 1) - u(b) = 1 And u(b) - u(b - 1) = 1 Then d = "" Else If u(b) - u(b - 1) = 1 Then c = "-" Else c = ", " End If d = c & u(b) End If e = e & d Next u_4 = u(1) & e End Function
[/vba]
так короче [vba]
Код
Function u_4(u As Range) u_4 = u(1) For b = 2 To u.Count If u(b + 1) - u(b) = 1 And u(b) - u(b - 1) = 1 Then d = "" Else c = ", " If u(b) - u(b - 1) = 1 Then c = "-" d = c & u(b) End If u_4 = u_4 & d Next End Function
[/vba]
вариант - две формулы в доп.столбце
АпДэйт добавил УДФ
[vba]
Код
Function u_4(u As Range) a = u.Count e = "" For b = 2 To a If u(b + 1) - u(b) = 1 And u(b) - u(b - 1) = 1 Then d = "" Else If u(b) - u(b - 1) = 1 Then c = "-" Else c = ", " End If d = c & u(b) End If e = e & d Next u_4 = u(1) & e End Function
[/vba]
так короче [vba]
Код
Function u_4(u As Range) u_4 = u(1) For b = 2 To u.Count If u(b + 1) - u(b) = 1 And u(b) - u(b - 1) = 1 Then d = "" Else c = ", " If u(b) - u(b - 1) = 1 Then c = "-" d = c & u(b) End If u_4 = u_4 & d Next End Function
В очередной раз (лень искать предыдущие случаи) добавлю свои пять копеек в виде нетрадиционной экзотики, когда можно все необходимые расчеты переложить на внутреннюю эксельную арифметику диапазонов, делая "снаружи" только вызовы соответствующих методов и компоновку генерируемого материала. [vba]
Код
Sub generate_IntRanges_By_ExcelRanges() Dim rngSrc As Range, rng As Range, area As Range, str As String, arr, item
Set rngSrc = Range("A1:A8") 'диапазон исходных данных (числа в столбик)
arr = Split("A" & Replace(Join(Application.Transpose(rngSrc), ","), ",", ",A"), ",") Set rng = Range(arr(0)) For Each item In arr Set rng = Union(rng, Range(item)) Next For Each area In rng.Areas str = str & "," & area.Address(0, 0) Next str = Replace(Replace(Mid(str, 2), ":", "-"), "A", "")
Debug.Print str 'строка результата: 1-3,5,7,9-11 End Sub
[/vba] По шагам внутри процесса получаются примерно следующие трансформации: [vba]
[/vba] Метод не то, чтобы самый краткий и быстрый, но, согласитесь, по-своему прикольный. Разумеется, со всеми естественными ограничениями Excel (типа миллион строк и т.п.).
[p.s.]Если нужна аналогичная функция рабочего листа (UDF), то оформляется на раз (добавлен пробел после запятой):[/p.s.] [vba]
Код
Function ЦЕЛЫЕ_ДИАПАЗОНЫ(rngSrc As Range) As String Dim rng As Range, area As Range, str As String, arr, item arr = Split("A" & Replace(Join(Application.Transpose(rngSrc), ","), ",", ",A"), ",") Set rng = Range(arr(0)) For Each item In arr Set rng = Union(rng, Range(item)) Next For Each area In rng.Areas str = str & ", " & area.Address(0, 0) Next ЦЕЛЫЕ_ДИАПАЗОНЫ = Replace(Replace(Mid(str, 3), ":", "-"), "A", "") End Function
[/vba]
В очередной раз (лень искать предыдущие случаи) добавлю свои пять копеек в виде нетрадиционной экзотики, когда можно все необходимые расчеты переложить на внутреннюю эксельную арифметику диапазонов, делая "снаружи" только вызовы соответствующих методов и компоновку генерируемого материала. [vba]
Код
Sub generate_IntRanges_By_ExcelRanges() Dim rngSrc As Range, rng As Range, area As Range, str As String, arr, item
Set rngSrc = Range("A1:A8") 'диапазон исходных данных (числа в столбик)
arr = Split("A" & Replace(Join(Application.Transpose(rngSrc), ","), ",", ",A"), ",") Set rng = Range(arr(0)) For Each item In arr Set rng = Union(rng, Range(item)) Next For Each area In rng.Areas str = str & "," & area.Address(0, 0) Next str = Replace(Replace(Mid(str, 2), ":", "-"), "A", "")
Debug.Print str 'строка результата: 1-3,5,7,9-11 End Sub
[/vba] По шагам внутри процесса получаются примерно следующие трансформации: [vba]
[/vba] Метод не то, чтобы самый краткий и быстрый, но, согласитесь, по-своему прикольный. Разумеется, со всеми естественными ограничениями Excel (типа миллион строк и т.п.).
[p.s.]Если нужна аналогичная функция рабочего листа (UDF), то оформляется на раз (добавлен пробел после запятой):[/p.s.] [vba]
Код
Function ЦЕЛЫЕ_ДИАПАЗОНЫ(rngSrc As Range) As String Dim rng As Range, area As Range, str As String, arr, item arr = Split("A" & Replace(Join(Application.Transpose(rngSrc), ","), ",", ",A"), ",") Set rng = Range(arr(0)) For Each item In arr Set rng = Union(rng, Range(item)) Next For Each area In rng.Areas str = str & ", " & area.Address(0, 0) Next ЦЕЛЫЕ_ДИАПАЗОНЫ = Replace(Replace(Mid(str, 3), ":", "-"), "A", "") End Function
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
