Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Как можно ускорить работу макроса на скрытие строк - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Как можно ускорить работу макроса на скрытие строк
graff9540 Дата: Воскресенье, 05.03.2023, 14:47 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Всем привет!
Подскажите пожалуйста, как можно ускорить работу макроса:
[vba]
Код
Sub СкрытьСтроки_х()
    If ActiveSheet.ListObjects.Count = 0 Then Exit Sub
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.EntireRow.Hidden = False
    Dim tb As ListObject
    For Each tb In ActiveSheet.ListObjects
        JobTb tb
    Next
    Application.ScreenUpdating = True
End Sub

Private Sub JobTb(tb As ListObject)
    Dim flag As Boolean
    Dim cl As Range
    For Each cl In tb.DataBodyRange.Columns(1).Cells
        flag = False
        If cl.Cells(1, 17).Value = "скрыть" Then
            flag = True
        End If
        Select Case cl.Interior.Color
        Case 11389944, 14277081
        Case Else
            flag = True
        End Select
         
        If flag Then cl.EntireRow.Hidden = True
    Next
End Sub
[/vba]
Суть вопроса заключается в том, что при наличии в "умной таблице" более 3 500 тыс. строк он, макрос, очень долго скрывает строки - более 5 минут.
Файл не выкладываю, т.к. его объем велик, а если прикрепить урезанный вариант, то скорость работы макроса сложно будет оценить.
Спасибо.
 
Ответить
СообщениеВсем привет!
Подскажите пожалуйста, как можно ускорить работу макроса:
[vba]
Код
Sub СкрытьСтроки_х()
    If ActiveSheet.ListObjects.Count = 0 Then Exit Sub
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.EntireRow.Hidden = False
    Dim tb As ListObject
    For Each tb In ActiveSheet.ListObjects
        JobTb tb
    Next
    Application.ScreenUpdating = True
End Sub

Private Sub JobTb(tb As ListObject)
    Dim flag As Boolean
    Dim cl As Range
    For Each cl In tb.DataBodyRange.Columns(1).Cells
        flag = False
        If cl.Cells(1, 17).Value = "скрыть" Then
            flag = True
        End If
        Select Case cl.Interior.Color
        Case 11389944, 14277081
        Case Else
            flag = True
        End Select
         
        If flag Then cl.EntireRow.Hidden = True
    Next
End Sub
[/vba]
Суть вопроса заключается в том, что при наличии в "умной таблице" более 3 500 тыс. строк он, макрос, очень долго скрывает строки - более 5 минут.
Файл не выкладываю, т.к. его объем велик, а если прикрепить урезанный вариант, то скорость работы макроса сложно будет оценить.
Спасибо.

Автор - graff9540
Дата добавления - 05.03.2023 в 14:47
graff9540 Дата: Воскресенье, 05.03.2023, 15:27 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

 
Ответить
СообщениеКросс

Автор - graff9540
Дата добавления - 05.03.2023 в 15:27
graff9540 Дата: Вторник, 04.04.2023, 19:13 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Всем привет!
Вопрос по теме еще в актуальном состоянии!!
Подскажите, может быть есть решение?
 
Ответить
СообщениеВсем привет!
Вопрос по теме еще в актуальном состоянии!!
Подскажите, может быть есть решение?

Автор - graff9540
Дата добавления - 04.04.2023 в 19:13
Pelena Дата: Вторник, 04.04.2023, 19:40 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 19238
Репутация: 4433 ±
Замечаний: ±

Excel 365 & Mac Excel
Недавно была похожая тема с несколькими решениями


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеНедавно была похожая тема с несколькими решениями

Автор - Pelena
Дата добавления - 04.04.2023 в 19:40
graff9540 Дата: Среда, 05.04.2023, 00:07 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Pelena, спасибо за ссылку
Недавно была похожая тема с несколькими решениями
.
Данную тему я читал. На ее основе набросал свой макрос:
[vba]
Код
Sub СкрытьБелыхИ_х()

Dim с As Date
Dim d As Single
'Больше не обновляем страницы после каждого действия
  Application.ScreenUpdating = False
'Отключаем события
  Application.EnableEvents = False
'Расчёты переводим в ручной режим
  Application.Calculation = xlCalculationManual
  c = Time
    If ActiveSheet.ListObjects.Count = 0 Then Exit Sub
     
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.EntireRow.Hidden = False
    Dim tb As ListObject
    For Each tb In ActiveSheet.ListObjects
        JobTb tb
    Next
    Application.ScreenUpdating = True
    d = (Time - c) * 24 * 60 * 60
'Расчёты переводим в автоматический режим
  Application.Calculation = xlCalculationAutomatic
'Включаем события
  Application.EnableEvents = True
'Включаем обновление страниц после каждого действия
  Application.ScreenUpdating = True

    MsgBox "Время выполения макроса составило: " & d & " c.", vbInformation, "Отчет"
End Sub
Private Sub JobTb(tb As ListObject)
    Dim flag As Boolean
    Dim cl As Range
    For Each cl In tb.DataBodyRange.Columns(1).Cells
        flag = False
        If cl.Cells(1, 14).Value = "х" Then
            flag = True
        End If
        Select Case cl.Interior.Color
        Case 11389944, 14277081
        Case Else
            flag = True
        End Select
         
        If flag Then cl.EntireRow.Hidden = True
    Next
End Sub
[/vba]
Вот результаты:
число строк 3616:
- время выполнения доработанного макроса 3 с.
- время выполнения без доработки Excel после 5 минут обработки не отвечает :'( %)
И ВОТ РЕЗУЛЬТАТ - 85757 с

Но вот еще что меня волнует:
1. Как привязать макрос на работу в с "умной таблицей"?
2. Возможно ли сделать так, чтобы столбец, в котором имеется значение "скрыть" был постоянно скрыт от глаз пользователя?
3. Возможно ли сделать так, чтобы строки 5-9 были постоянно скрыты от глаз пользователя?

Буду признателен за оказанную помощь.

PS: Файл немного уменьшил в объеме - убрал строки, дабы попасть в размер.
К сообщению приложен файл: primer_avtomaticheskivosstanov.xlsm (499.6 Kb)


Сообщение отредактировал graff9540 - Среда, 05.04.2023, 00:18
 
Ответить
СообщениеPelena, спасибо за ссылку
Недавно была похожая тема с несколькими решениями
.
Данную тему я читал. На ее основе набросал свой макрос:
[vba]
Код
Sub СкрытьБелыхИ_х()

Dim с As Date
Dim d As Single
'Больше не обновляем страницы после каждого действия
  Application.ScreenUpdating = False
'Отключаем события
  Application.EnableEvents = False
'Расчёты переводим в ручной режим
  Application.Calculation = xlCalculationManual
  c = Time
    If ActiveSheet.ListObjects.Count = 0 Then Exit Sub
     
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.EntireRow.Hidden = False
    Dim tb As ListObject
    For Each tb In ActiveSheet.ListObjects
        JobTb tb
    Next
    Application.ScreenUpdating = True
    d = (Time - c) * 24 * 60 * 60
'Расчёты переводим в автоматический режим
  Application.Calculation = xlCalculationAutomatic
'Включаем события
  Application.EnableEvents = True
'Включаем обновление страниц после каждого действия
  Application.ScreenUpdating = True

    MsgBox "Время выполения макроса составило: " & d & " c.", vbInformation, "Отчет"
End Sub
Private Sub JobTb(tb As ListObject)
    Dim flag As Boolean
    Dim cl As Range
    For Each cl In tb.DataBodyRange.Columns(1).Cells
        flag = False
        If cl.Cells(1, 14).Value = "х" Then
            flag = True
        End If
        Select Case cl.Interior.Color
        Case 11389944, 14277081
        Case Else
            flag = True
        End Select
         
        If flag Then cl.EntireRow.Hidden = True
    Next
End Sub
[/vba]
Вот результаты:
число строк 3616:
- время выполнения доработанного макроса 3 с.
- время выполнения без доработки Excel после 5 минут обработки не отвечает :'( %)
И ВОТ РЕЗУЛЬТАТ - 85757 с

Но вот еще что меня волнует:
1. Как привязать макрос на работу в с "умной таблицей"?
2. Возможно ли сделать так, чтобы столбец, в котором имеется значение "скрыть" был постоянно скрыт от глаз пользователя?
3. Возможно ли сделать так, чтобы строки 5-9 были постоянно скрыты от глаз пользователя?

Буду признателен за оказанную помощь.

PS: Файл немного уменьшил в объеме - убрал строки, дабы попасть в размер.

Автор - graff9540
Дата добавления - 05.04.2023 в 00:07
_Boroda_ Дата: Среда, 05.04.2023, 09:32 | Сообщение № 6
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16675
Репутация: 6481 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
graff9540, положите файл без макроса. А то безопасники блокируют


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщениеgraff9540, положите файл без макроса. А то безопасники блокируют

Автор - _Boroda_
Дата добавления - 05.04.2023 в 09:32
graff9540 Дата: Среда, 05.04.2023, 15:11 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Ок.
К сообщению приложен файл: 2853350.xlsx (32.2 Kb)
 
Ответить
СообщениеОк.

Автор - graff9540
Дата добавления - 05.04.2023 в 15:11
graff9540 Дата: Четверг, 06.04.2023, 00:35 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Но вот еще что меня волнует:
2. Возможно ли сделать так, чтобы столбец, в котором имеется значение "скрыть" был постоянно скрыт от глаз пользователя?
3. Возможно ли сделать так, чтобы строки 5-9 были постоянно скрыты от глаз пользователя?

Вот добавил макрос в корень "Эта книга":
[vba]
Код
Sub HideColumnsRows()
   With Worksheets("Литс 1")
      .Columns(14).Hidden = True
      .Rows("5:9").Hidden = True
   End With
End Sub
[/vba]

Вроде все стартует. Но не могу понять, как сделать так, чтобы он реагировал на автоматическое скрытие даже тогда, когда пользователь их "покажет".


Сообщение отредактировал graff9540 - Четверг, 06.04.2023, 00:36
 
Ответить
Сообщение
Но вот еще что меня волнует:
2. Возможно ли сделать так, чтобы столбец, в котором имеется значение "скрыть" был постоянно скрыт от глаз пользователя?
3. Возможно ли сделать так, чтобы строки 5-9 были постоянно скрыты от глаз пользователя?

Вот добавил макрос в корень "Эта книга":
[vba]
Код
Sub HideColumnsRows()
   With Worksheets("Литс 1")
      .Columns(14).Hidden = True
      .Rows("5:9").Hidden = True
   End With
End Sub
[/vba]

Вроде все стартует. Но не могу понять, как сделать так, чтобы он реагировал на автоматическое скрытие даже тогда, когда пользователь их "покажет".

Автор - graff9540
Дата добавления - 06.04.2023 в 00:35
MikeVol Дата: Четверг, 06.04.2023, 15:14 | Сообщение № 9
Группа: Проверенные
Ранг: Обитатель
Сообщений: 315
Репутация: 61 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
graff9540, Здравствуйте. Так вам же дали ответ на другом форуме! Поделитесь кодом здесь и закрыли тему с дублями на разных форумах.


Ученик.
 
Ответить
Сообщениеgraff9540, Здравствуйте. Так вам же дали ответ на другом форуме! Поделитесь кодом здесь и закрыли тему с дублями на разных форумах.

Автор - MikeVol
Дата добавления - 06.04.2023 в 15:14
graff9540 Дата: Четверг, 06.04.2023, 22:46 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Здравствуйте. Так вам же дали ответ на другом форуме! Поделитесь кодом здесь и закрыли тему с дублями на разных форумах.

Добрый день/вечер. Да, действительно, уважаемый МатросНаЗебре с planetaexcel любезно предложил код макроса. За что ему огромное спасибо.

Я его протестировал. И если Вы внимательно читали тему на том форуме, то должны были увидеть результаты.

Насчет закрытия темы, вопрос интересный, так как при большом количестве строк в умной таблице макрос не такой шустрый.
Возможно, найдутся пользователи форума, которым будет интересно подкинуть идей по поводу оптимизации макроса.
 
Ответить
Сообщение
Здравствуйте. Так вам же дали ответ на другом форуме! Поделитесь кодом здесь и закрыли тему с дублями на разных форумах.

Добрый день/вечер. Да, действительно, уважаемый МатросНаЗебре с planetaexcel любезно предложил код макроса. За что ему огромное спасибо.

Я его протестировал. И если Вы внимательно читали тему на том форуме, то должны были увидеть результаты.

Насчет закрытия темы, вопрос интересный, так как при большом количестве строк в умной таблице макрос не такой шустрый.
Возможно, найдутся пользователи форума, которым будет интересно подкинуть идей по поводу оптимизации макроса.

Автор - graff9540
Дата добавления - 06.04.2023 в 22:46
Gustav Дата: Пятница, 07.04.2023, 00:35 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2763
Репутация: 1140 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
1. Как привязать макрос на работу в с "умной таблицей"?

Так он у Вас разработан для умной таблицы. ListObject - это она и есть.

- время выполнения доработанного макроса 3 с.
- время выполнения без доработки Excel после 5 минут обработки не отвечает

3 секунды - это много, что ли? Чем не устраивает?

[p.s.]Если много, то вот вариант на 1 секунду ("1С" практически :)):[/p.s.]
[vba]
Код
Private Sub JobTurbo(tb As ListObject)
    Dim wks As Worksheet, rng As Range, colA As Range, column As Range
    Dim val As Variant, t As Variant, i As Long
    
    t = Timer
    Set colA = tb.DataBodyRange.Columns(1) 'колонка цвета
    Set column = tb.DataBodyRange.Columns(14) 'колонка крестиков
    
    Set wks = tb.Parent
    Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2)
    Set rng = Intersect(rng, column.EntireRow) 'временная колонка отметок (единичек)
    val = rng.Value
    For i = 1 To column.Cells.Count
        'отмечаем скрываемые строки единичками
        If column.Cells(i) = "х" Then val(i, 1) = 1 'здесь по крестику
        Select Case colA.Cells(i).Interior.Color
            Case 11389944, 14277081
            Case Else
                val(i, 1) = 1 'и здесь по цвету
        End Select
    Next i
    rng.Value = val
    
    On Error Resume Next
    rng.SpecialCells(xlCellTypeConstants, 1).EntireRow.Hidden = True '1 = Числа
    On Error GoTo 0
    rng.EntireColumn.Delete 'удаление временной колонки отметок (единичек)
    
    Debug.Print Timer - t
End Sub
[/vba]
Обратите внимание, что название процедуры изменено: JobTurbo вместо JobTb. Поэтому в главной программе Sub СкрытьБелыхИ_х() нужно будет закомментировать вызов JobTb и добавить вызов JobTurbo в этом фрагменте:
[vba]
Код
    For Each tb In ActiveSheet.ListObjects
        'JobTb tb
        JobTurbo tb
    Next
[/vba]


МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Пятница, 07.04.2023, 02:30
 
Ответить
Сообщение
1. Как привязать макрос на работу в с "умной таблицей"?

Так он у Вас разработан для умной таблицы. ListObject - это она и есть.

- время выполнения доработанного макроса 3 с.
- время выполнения без доработки Excel после 5 минут обработки не отвечает

3 секунды - это много, что ли? Чем не устраивает?

[p.s.]Если много, то вот вариант на 1 секунду ("1С" практически :)):[/p.s.]
[vba]
Код
Private Sub JobTurbo(tb As ListObject)
    Dim wks As Worksheet, rng As Range, colA As Range, column As Range
    Dim val As Variant, t As Variant, i As Long
    
    t = Timer
    Set colA = tb.DataBodyRange.Columns(1) 'колонка цвета
    Set column = tb.DataBodyRange.Columns(14) 'колонка крестиков
    
    Set wks = tb.Parent
    Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2)
    Set rng = Intersect(rng, column.EntireRow) 'временная колонка отметок (единичек)
    val = rng.Value
    For i = 1 To column.Cells.Count
        'отмечаем скрываемые строки единичками
        If column.Cells(i) = "х" Then val(i, 1) = 1 'здесь по крестику
        Select Case colA.Cells(i).Interior.Color
            Case 11389944, 14277081
            Case Else
                val(i, 1) = 1 'и здесь по цвету
        End Select
    Next i
    rng.Value = val
    
    On Error Resume Next
    rng.SpecialCells(xlCellTypeConstants, 1).EntireRow.Hidden = True '1 = Числа
    On Error GoTo 0
    rng.EntireColumn.Delete 'удаление временной колонки отметок (единичек)
    
    Debug.Print Timer - t
End Sub
[/vba]
Обратите внимание, что название процедуры изменено: JobTurbo вместо JobTb. Поэтому в главной программе Sub СкрытьБелыхИ_х() нужно будет закомментировать вызов JobTb и добавить вызов JobTurbo в этом фрагменте:
[vba]
Код
    For Each tb In ActiveSheet.ListObjects
        'JobTb tb
        JobTurbo tb
    Next
[/vba]

Автор - Gustav
Дата добавления - 07.04.2023 в 00:35
graff9540 Дата: Пятница, 07.04.2023, 08:53 | Сообщение № 12
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Уважаемый Gustav. Спасибо!!
Реально скорость возросла. Перекинул на рабочий файл и, по сравнению с моим кодом, скорость обработки увеличилась существенно.
Спасибо!!!
 
Ответить
СообщениеУважаемый Gustav. Спасибо!!
Реально скорость возросла. Перекинул на рабочий файл и, по сравнению с моим кодом, скорость обработки увеличилась существенно.
Спасибо!!!

Автор - graff9540
Дата добавления - 07.04.2023 в 08:53
RAN Дата: Пятница, 07.04.2023, 14:43 | Сообщение № 13
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010


Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Пятница, 07.04.2023, 14:45
 
Ответить
graff9540 Дата: Пятница, 07.04.2023, 15:15 | Сообщение № 14
Группа: Пользователи
Ранг: Новичок
Сообщений: 23
Репутация: 0 ±
Замечаний: 0% ±

Спасибо, буду изучать.
 
Ответить
СообщениеСпасибо, буду изучать.

Автор - graff9540
Дата добавления - 07.04.2023 в 15:15
Gustav Дата: Пятница, 07.04.2023, 22:26 | Сообщение № 15
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2763
Репутация: 1140 ±
Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1
Будучи раскочегаренным на своей реализации плюс ссылки от RAN поизучал - в общем, выкатываю еще две реализации на базе своей исходной: JobTurbo2 и JobTurbo3.

Что изменил? Во 2-й версии стал читать сразу массив ячеек из колонки N и анализировать его уже в массиве. Обращение к ячейкам в цикле осталось только для получения цвета заливки, причём число таких обращений тоже сократилось - обращаюсь к анализу цвета только если значение ячейки не "крестик" (делю в IFе). Потому что если оно уже и так "крестик" (т.е. надо скрывать строку), то анализ цвета в этом случае будет излишним. Запуски версии 2 в разное время дали разные результаты с довольно заметной погрешностью, но общее ощущение - по сравнению с 1-й версией стало немного пошустрее.

В 3-й версии пошёл дальше. В условиях того, что по условиям задачи надо скрыть почти все строки, оставив отображаться совсем немногие, попробовал сделать наоборот - скрыл вообще все, а затем отобразил те немногие, которые скрывать не надо. Не могу сказать, что стало еще быстрее, чем в версии 2. Скажем так, в тестах обе версии лидировали попеременно в пределах погрешности. Но версию 3, тем не менее, тоже захотелось показать.

[vba]
Код
Private Sub JobTurbo2(tb As ListObject)
    Dim wks As Worksheet, rng As Range, colA As Range, column As Range
    Dim val As Variant, t As Variant, valCol As Variant, i As Long, iMax As Long
    
    t = Timer
    Set colA = tb.DataBodyRange.Columns(1) 'колонка цвета
    Set column = tb.DataBodyRange.Columns(14) 'колонка крестиков
    
    Set wks = tb.Parent
    Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2)
    Set rng = Intersect(rng, column.EntireRow) 'временная колонка отметок (единичек)
    val = rng.Value
    valCol = column.Value
    iMax = column.Cells.Count
    For i = 1 To iMax
        'отмечаем скрываемые строки единичками
        If valCol(i, 1) = "х" Then
            val(i, 1) = 1 'здесь по крестику
        Else
            Select Case colA.Cells(i).Interior.Color
                Case 11389944, 14277081
                Case Else
                    val(i, 1) = 1 'и здесь по цвету
            End Select
        End If
    Next i
    rng.Value = val
    
    On Error Resume Next
    rng.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Hidden = True
    On Error GoTo 0
    rng.EntireColumn.Delete 'удаление временной колонки отметок (единичек)
    
    Debug.Print Timer - t
End Sub

Private Sub JobTurbo3(tb As ListObject)
    Dim wks As Worksheet, rng As Range, colA As Range, column As Range
    Dim val As Variant, t As Variant, valCol As Variant, i As Long, iMax As Long
    
    t = Timer
    Set colA = tb.DataBodyRange.Columns(1) 'колонка цвета
    Set column = tb.DataBodyRange.Columns(14) 'колонка крестиков
    
    Set wks = tb.Parent
    Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2)
    Set rng = Intersect(rng, column.EntireRow) 'временная колонка отметок (единичек)
    val = rng.Value
    valCol = column.Value
    iMax = column.Cells.Count
    For i = 1 To iMax
        'отмечаем скрываемые строки единичками
        If valCol(i, 1) = "х" Then
            val(i, 1) = 1 'здесь по крестику
        Else
            Select Case colA.Cells(i).Interior.Color
                Case 11389944, 14277081
                Case Else
                    val(i, 1) = 1 'и здесь по цвету
            End Select
        End If
    Next i
    rng.Value = val
    
    rng.EntireRow.Hidden = True 'сначала скрываем просто ВСЁ сразу
    On Error Resume Next 'и потом некоторые (меньшую часть) показываем
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False
    On Error GoTo 0
    rng.EntireColumn.Delete 'удаление временной колонки отметок (единичек)
    
    Debug.Print Timer - t
End Sub
[/vba]

И в целом мне понравилась общая идея - в процессе обработки делать вспомогательные вычисления за пределами UsedRange обрабатываемого листа и затем подчищать этот временный материал, восстанавливая исходный UsedRange. Т.е. как будто бы ничего и не было, а результат, тем не менее, имеется. Как-то раньше побаивался колбасить что-то лишнее на "боевом" рабочем листе, и, думаю, я совсем не одинок в числе таких побаивающихся. А тут, как говорится (в фильме "Весна"), "присел, задумался, открыл". Единственным ограничением подхода является условие неиспользования двух крайних правых колонок рабочего листа XFC и XFD (я временно "расширяюсь" вправо через столбец от UsedRange, чтобы при последующем удалении временного столбца никак не "зацепить" форматирование последнего столбца UsedRange - вот какой я деликатный! ;) ).


МОИ: Ник, Tip box: 41001663842605
 
Ответить
СообщениеБудучи раскочегаренным на своей реализации плюс ссылки от RAN поизучал - в общем, выкатываю еще две реализации на базе своей исходной: JobTurbo2 и JobTurbo3.

Что изменил? Во 2-й версии стал читать сразу массив ячеек из колонки N и анализировать его уже в массиве. Обращение к ячейкам в цикле осталось только для получения цвета заливки, причём число таких обращений тоже сократилось - обращаюсь к анализу цвета только если значение ячейки не "крестик" (делю в IFе). Потому что если оно уже и так "крестик" (т.е. надо скрывать строку), то анализ цвета в этом случае будет излишним. Запуски версии 2 в разное время дали разные результаты с довольно заметной погрешностью, но общее ощущение - по сравнению с 1-й версией стало немного пошустрее.

В 3-й версии пошёл дальше. В условиях того, что по условиям задачи надо скрыть почти все строки, оставив отображаться совсем немногие, попробовал сделать наоборот - скрыл вообще все, а затем отобразил те немногие, которые скрывать не надо. Не могу сказать, что стало еще быстрее, чем в версии 2. Скажем так, в тестах обе версии лидировали попеременно в пределах погрешности. Но версию 3, тем не менее, тоже захотелось показать.

[vba]
Код
Private Sub JobTurbo2(tb As ListObject)
    Dim wks As Worksheet, rng As Range, colA As Range, column As Range
    Dim val As Variant, t As Variant, valCol As Variant, i As Long, iMax As Long
    
    t = Timer
    Set colA = tb.DataBodyRange.Columns(1) 'колонка цвета
    Set column = tb.DataBodyRange.Columns(14) 'колонка крестиков
    
    Set wks = tb.Parent
    Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2)
    Set rng = Intersect(rng, column.EntireRow) 'временная колонка отметок (единичек)
    val = rng.Value
    valCol = column.Value
    iMax = column.Cells.Count
    For i = 1 To iMax
        'отмечаем скрываемые строки единичками
        If valCol(i, 1) = "х" Then
            val(i, 1) = 1 'здесь по крестику
        Else
            Select Case colA.Cells(i).Interior.Color
                Case 11389944, 14277081
                Case Else
                    val(i, 1) = 1 'и здесь по цвету
            End Select
        End If
    Next i
    rng.Value = val
    
    On Error Resume Next
    rng.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow.Hidden = True
    On Error GoTo 0
    rng.EntireColumn.Delete 'удаление временной колонки отметок (единичек)
    
    Debug.Print Timer - t
End Sub

Private Sub JobTurbo3(tb As ListObject)
    Dim wks As Worksheet, rng As Range, colA As Range, column As Range
    Dim val As Variant, t As Variant, valCol As Variant, i As Long, iMax As Long
    
    t = Timer
    Set colA = tb.DataBodyRange.Columns(1) 'колонка цвета
    Set column = tb.DataBodyRange.Columns(14) 'колонка крестиков
    
    Set wks = tb.Parent
    Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2)
    Set rng = Intersect(rng, column.EntireRow) 'временная колонка отметок (единичек)
    val = rng.Value
    valCol = column.Value
    iMax = column.Cells.Count
    For i = 1 To iMax
        'отмечаем скрываемые строки единичками
        If valCol(i, 1) = "х" Then
            val(i, 1) = 1 'здесь по крестику
        Else
            Select Case colA.Cells(i).Interior.Color
                Case 11389944, 14277081
                Case Else
                    val(i, 1) = 1 'и здесь по цвету
            End Select
        End If
    Next i
    rng.Value = val
    
    rng.EntireRow.Hidden = True 'сначала скрываем просто ВСЁ сразу
    On Error Resume Next 'и потом некоторые (меньшую часть) показываем
    rng.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = False
    On Error GoTo 0
    rng.EntireColumn.Delete 'удаление временной колонки отметок (единичек)
    
    Debug.Print Timer - t
End Sub
[/vba]

И в целом мне понравилась общая идея - в процессе обработки делать вспомогательные вычисления за пределами UsedRange обрабатываемого листа и затем подчищать этот временный материал, восстанавливая исходный UsedRange. Т.е. как будто бы ничего и не было, а результат, тем не менее, имеется. Как-то раньше побаивался колбасить что-то лишнее на "боевом" рабочем листе, и, думаю, я совсем не одинок в числе таких побаивающихся. А тут, как говорится (в фильме "Весна"), "присел, задумался, открыл". Единственным ограничением подхода является условие неиспользования двух крайних правых колонок рабочего листа XFC и XFD (я временно "расширяюсь" вправо через столбец от UsedRange, чтобы при последующем удалении временного столбца никак не "зацепить" форматирование последнего столбца UsedRange - вот какой я деликатный! ;) ).

Автор - Gustav
Дата добавления - 07.04.2023 в 22:26
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!