Добрый день. Сразу суть вопроса: Необходимо определить диапазон в зависимости от значения ячеек. В столбце А, начиная с второй строки введены значения от 1 до 10. т.е. вот так:
1 2 3 1 2 3 4 1 2 3 4 5 1 2 1 2 3
Диапазон определяется минимальным значением и максимальным. Можно ли определить диапазоны без цикла по ячейкам? У меня получилось вот так: [vba]
Код
Sub rangeFND() Application.ScreenUpdating = False Dim rRange As Range, rCell As Range With Sheets(1) For Each rCell In .Cells(2, 1).Resize(.UsedRange.Rows.Count, 1) If rCell.Value < rCell.Offset(1, 0).Value Then
If rRange Is Nothing Then Set rRange = rCell End If
If rCell.Value > rCell.Offset(-1, 0).Value Then Set rRange = Union(rRange, rCell) End If Else If rCell.Value = "" Then Exit Sub Set rRange = Union(rRange, rCell) Debug.Print rRange.Address rRange.Offset(0, 1).Formula = rRange.Address Set rRange = Nothing End If Next End With Application.ScreenUpdating = True End Sub
[/vba]
Буду благодарен за любой совет и помощь.
Добрый день. Сразу суть вопроса: Необходимо определить диапазон в зависимости от значения ячеек. В столбце А, начиная с второй строки введены значения от 1 до 10. т.е. вот так:
1 2 3 1 2 3 4 1 2 3 4 5 1 2 1 2 3
Диапазон определяется минимальным значением и максимальным. Можно ли определить диапазоны без цикла по ячейкам? У меня получилось вот так: [vba]
Код
Sub rangeFND() Application.ScreenUpdating = False Dim rRange As Range, rCell As Range With Sheets(1) For Each rCell In .Cells(2, 1).Resize(.UsedRange.Rows.Count, 1) If rCell.Value < rCell.Offset(1, 0).Value Then
If rRange Is Nothing Then Set rRange = rCell End If
If rCell.Value > rCell.Offset(-1, 0).Value Then Set rRange = Union(rRange, rCell) End If Else If rCell.Value = "" Then Exit Sub Set rRange = Union(rRange, rCell) Debug.Print rRange.Address rRange.Offset(0, 1).Formula = rRange.Address Set rRange = Nothing End If Next End With Application.ScreenUpdating = True End Sub
Попробовал сделать с коллекцией, но получились те же яйца только в профиль: [vba]
Код
Sub rangeFND2() Application.ScreenUpdating = False Dim rRange As Range, rCell As Range, r&, v$ Dim cl As New Collection With Sheets(1) On Error GoTo err For r = 1 To .UsedRange.Rows.Count v = .Cells(r, 1).Value cl.Add v Next
For r = 2 To cl.Count If cl.Item(r) < cl.Item(r + 1) Then If rRange Is Nothing Then Set rRange = .Cells(r, 1) End If
If cl.Item(r) > cl.Item(r - 1) Then Set rRange = Union(rRange, .Cells(r, 1)) End If Else err: Set rRange = Union(rRange, .Cells(r, 1)) Debug.Print rRange.Address rRange.Offset(0, 1).Formula = rRange.Address Set rRange = Nothing End If Next
End With Application.ScreenUpdating = True End Sub
[/vba]
Попробовал сделать с коллекцией, но получились те же яйца только в профиль: [vba]
Код
Sub rangeFND2() Application.ScreenUpdating = False Dim rRange As Range, rCell As Range, r&, v$ Dim cl As New Collection With Sheets(1) On Error GoTo err For r = 1 To .UsedRange.Rows.Count v = .Cells(r, 1).Value cl.Add v Next
For r = 2 To cl.Count If cl.Item(r) < cl.Item(r + 1) Then If rRange Is Nothing Then Set rRange = .Cells(r, 1) End If
If cl.Item(r) > cl.Item(r - 1) Then Set rRange = Union(rRange, .Cells(r, 1)) End If Else err: Set rRange = Union(rRange, .Cells(r, 1)) Debug.Print rRange.Address rRange.Offset(0, 1).Formula = rRange.Address Set rRange = Nothing End If Next
End With Application.ScreenUpdating = True End Sub
Sub www() Dim r As Range, a As Range, c As Range Set r = Range("b2:b" & Cells(Rows.Count, 1).End(xlUp).Row) r.FormulaR1C1 = "=IF(RC[-1]>R[-1]C[-1],"""",1)" r = r.Value For Each a In r.SpecialCells(4).Areas Set c = a.Offset(-1).Resize(a.Count + 1) c = c.Offset(, -1).Address Next End Sub
Sub www() Dim r As Range, a As Range, c As Range Set r = Range("b2:b" & Cells(Rows.Count, 1).End(xlUp).Row) r.FormulaR1C1 = "=IF(RC[-1]>R[-1]C[-1],"""",1)" r = r.Value For Each a In r.SpecialCells(4).Areas Set c = a.Offset(-1).Resize(a.Count + 1) c = c.Offset(, -1).Address Next End Sub
Прошу прощения, видимо забыл указать в первом посте, что требуется не так "решить все без цикла", как найти вариант, который будет работать быстрее. При большем кол-ве строк. На данный момент код KuklP работает (чисто визуально) медленне чем мои =\. Мб какой-нибудь вариант с массивами? Я просто в них не особо разбираюсь.
Прошу прощения, видимо забыл указать в первом посте, что требуется не так "решить все без цикла", как найти вариант, который будет работать быстрее. При большем кол-ве строк. На данный момент код KuklP работает (чисто визуально) медленне чем мои =\. Мб какой-нибудь вариант с массивами? Я просто в них не особо разбираюсь.SkyPro
Мой предыдущий код будет работать тем быстрей, чем длинней будут последовательности чисел. На массивах: [vba]
Код
Sub www() Dim a, i&, s$ a = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Value For i = 2 To UBound(a) If a(i, 1) > Val(a(i - 1, 1)) Then s = IIf(s = "", Cells(i, 1).Address, s) Else s = s & ":" & Cells(i - 1, 1).Address a(i - 1, 1) = s: s = Cells(i, 1).Address End If Next s = s & ":" & Cells(i - 1, 1).Address a(i - 1, 1) = s For i = UBound(a) To 2 Step -1 If IsNumeric(a(i, 1)) Then a(i, 1) = a(i + 1, 1) Next [b1].Resize(UBound(a)) = a End Sub
[/vba]
Мой предыдущий код будет работать тем быстрей, чем длинней будут последовательности чисел. На массивах: [vba]
Код
Sub www() Dim a, i&, s$ a = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Value For i = 2 To UBound(a) If a(i, 1) > Val(a(i - 1, 1)) Then s = IIf(s = "", Cells(i, 1).Address, s) Else s = s & ":" & Cells(i - 1, 1).Address a(i - 1, 1) = s: s = Cells(i, 1).Address End If Next s = s & ":" & Cells(i - 1, 1).Address a(i - 1, 1) = s For i = UBound(a) To 2 Step -1 If IsNumeric(a(i, 1)) Then a(i, 1) = a(i + 1, 1) Next [b1].Resize(UBound(a)) = a End Sub
Нет Это я для наглядности добавил (вот такой своеобразный отладчик). Достаточно просто определить диапазон, произвести действия в этом диапазоне и перейти к следующему. Вот только первый вариант работает медленно, второй так же (чисто визуально, никогда не добавлял счетчик времени в макросы). Вот и вопрос в том, что бы с наименьшими затратами ресурсов и времени определять диапазоны. Сейчас пытась разобраться с массивами. Но успеха пока нет.
Нет Это я для наглядности добавил (вот такой своеобразный отладчик). Достаточно просто определить диапазон, произвести действия в этом диапазоне и перейти к следующему. Вот только первый вариант работает медленно, второй так же (чисто визуально, никогда не добавлял счетчик времени в макросы). Вот и вопрос в том, что бы с наименьшими затратами ресурсов и времени определять диапазоны. Сейчас пытась разобраться с массивами. Но успеха пока нет.SkyPro
Вобщем попробовал я загнать сначала в массив весь столбец (по примеру Сергея), а потом уже разбираться с ним, но реального прироста в производительности не увидел =\ Видимо у меня руки не оттуда ростут Попробовал заливать диапазоны цветом, так макросы по пол минуты на 1,5 к строк работают.
Вобщем попробовал я загнать сначала в массив весь столбец (по примеру Сергея), а потом уже разбираться с ним, но реального прироста в производительности не увидел =\ Видимо у меня руки не оттуда ростут Попробовал заливать диапазоны цветом, так макросы по пол минуты на 1,5 к строк работают.SkyPro
KuklP, насколько я понимаю, то вот єта строка:[vba]
Код
[b1].Resize(UBound(a)) = a
[/vba] Выводит все полученные диапазоны в колонку B. А как таким же быстрым образом обработать полученные диапазоны? Допустим, покрасить их в какой-нибудь цвет (для каждого разный). Пробовал вот так:[vba]
Код
F = 10000 For i = UBound(a) To 2 Step -1 If IsNumeric(a(i, 1)) Then a(i, 1) = a(i + 1, 1) Range(a(i, 1)).Interior.Color = F F = F + 100 Next
[/vba] Но макрос просто нереально долго начинает работать.
KuklP, насколько я понимаю, то вот єта строка:[vba]
Код
[b1].Resize(UBound(a)) = a
[/vba] Выводит все полученные диапазоны в колонку B. А как таким же быстрым образом обработать полученные диапазоны? Допустим, покрасить их в какой-нибудь цвет (для каждого разный). Пробовал вот так:[vba]
Код
F = 10000 For i = UBound(a) To 2 Step -1 If IsNumeric(a(i, 1)) Then a(i, 1) = a(i + 1, 1) Range(a(i, 1)).Interior.Color = F F = F + 100 Next
[/vba] Но макрос просто нереально долго начинает работать.SkyPro
Дык, форматирование ячеек - долгая операция. Тут ничего не поделать. Только что на Планете писал - с данными надо работать, а не с фантиками и будет счастье
Дык, форматирование ячеек - долгая операция. Тут ничего не поделать. Только что на Планете писал - с данными надо работать, а не с фантиками и будет счастье KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
