Доброго времени суток. Написал код для скрытия строк (если значение в ячейке нулевое, то строку скрыть), но т.к. этот код действует на десятки тысяч строк в объемном файле, то он считает в течение длительного времени (3-4 минуты). Помогите в оптимизации кода. В примере код конечно намного быстрее действует, но все равно 3-5 секунд. [vba]
Код
Sub Скругленныйпрямоугольник1_Щелчок() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Application.DisplayStatusBar = False Dim i For i = 16 To 38715 If Cells(i, 14).Value = 0 Then Rows(i).EntireRow.Hidden = True Else: Rows(i).EntireRow.Hidden = False ' End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.DisplayStatusBar = True End Sub
[/vba]
Доброго времени суток. Написал код для скрытия строк (если значение в ячейке нулевое, то строку скрыть), но т.к. этот код действует на десятки тысяч строк в объемном файле, то он считает в течение длительного времени (3-4 минуты). Помогите в оптимизации кода. В примере код конечно намного быстрее действует, но все равно 3-5 секунд. [vba]
Код
Sub Скругленныйпрямоугольник1_Щелчок() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Application.DisplayStatusBar = False Dim i For i = 16 To 38715 If Cells(i, 14).Value = 0 Then Rows(i).EntireRow.Hidden = True Else: Rows(i).EntireRow.Hidden = False ' End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.DisplayStatusBar = True End Sub
Fencer, Все потому, что у Вас обрабатывается очень большое кол-во строк, не зависимо от наличия в них значений. Сделайте неопределенный диапазон. В Вашем случае 38715 нужно заменить на Activesheet.UsedRange.Rows.Count [vba]
Код
For i = 16 To ActiveSheet.UsedRange.Rows.Count
[/vba]
Я обычно использую вот такую конструкцию: [vba]
Код
Dim rCell As Range With ActiveSheet For Each rCell In .Cells(.UsedRange.Row, 14).Resize(.UsedRange.Rows.Count) If Not IsEmpty(rCell) Then rCell.EntireRow.Hidden = IIf(rCell.Value = 0, True, False) Next rCell End With
[/vba]
Fencer, Все потому, что у Вас обрабатывается очень большое кол-во строк, не зависимо от наличия в них значений. Сделайте неопределенный диапазон. В Вашем случае 38715 нужно заменить на Activesheet.UsedRange.Rows.Count [vba]
Код
For i = 16 To ActiveSheet.UsedRange.Rows.Count
[/vba]
Я обычно использую вот такую конструкцию: [vba]
Код
Dim rCell As Range With ActiveSheet For Each rCell In .Cells(.UsedRange.Row, 14).Resize(.UsedRange.Rows.Count) If Not IsEmpty(rCell) Then rCell.EntireRow.Hidden = IIf(rCell.Value = 0, True, False) Next rCell End With
В Вашем случае 38715 нужно заменить на Activesheet.UsedRange.Rows.Count For i = 16 To ActiveSheet.UsedRange.Rows.Count
Простите, напортачил, это у меня будет не последняя строка, а кол-во использованных, нужно нет так. В Вашем случае нужно ввести переменную, которая будет содержать номер последней строки: [vba]
Код
Dim i, lR As Long lR = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 For i = 16 To lR
[/vba] Ну или использовать код, который предложил в предыдущем посту.
[offtop]Все нужно идти отдыхать, голова не варит [/offtop]
В Вашем случае 38715 нужно заменить на Activesheet.UsedRange.Rows.Count For i = 16 To ActiveSheet.UsedRange.Rows.Count
Простите, напортачил, это у меня будет не последняя строка, а кол-во использованных, нужно нет так. В Вашем случае нужно ввести переменную, которая будет содержать номер последней строки: [vba]
Код
Dim i, lR As Long lR = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 For i = 16 To lR
[/vba] Ну или использовать код, который предложил в предыдущем посту.
[offtop]Все нужно идти отдыхать, голова не варит [/offtop]Mikael
Dim rCell As Range With ActiveSheet For Each rCell In .Cells(.UsedRange.Row, 14).Resize(.UsedRange.Rows.Count) If Not IsEmpty(rCell) Then rCell.EntireRow.Hidden = IIf(rCell.Value = 0, True, False) Next rCell End With
Mikael, спасибо. Этот код сократил время где то в 5 раз. Как еще можно оптимизировать?)
Dim rCell As Range With ActiveSheet For Each rCell In .Cells(.UsedRange.Row, 14).Resize(.UsedRange.Rows.Count) If Not IsEmpty(rCell) Then rCell.EntireRow.Hidden = IIf(rCell.Value = 0, True, False) Next rCell End With
Mikael, спасибо. Этот код сократил время где то в 5 раз. Как еще можно оптимизировать?)Fencer
With ActiveSheet Set Wrange = .Cells(.UsedRange.Row, 14).Resize(.UsedRange.Rows.Count) Set RS = .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) Set Rf = .Cells.SpecialCells(xlCellTypeFormulas, xlNumbers) For Each rCell In Union(Intersect(Wrange, RS), Intersect(Wrange, Rf)) If Not IsEmpty(rCell) Then rCell.EntireRow.Hidden = IIf(rCell.Value = 0, True, False) Next rCell End With
[/vba]
ну может чуток подсократит время.
[vba]
Код
With ActiveSheet Set Wrange = .Cells(.UsedRange.Row, 14).Resize(.UsedRange.Rows.Count) Set RS = .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) Set Rf = .Cells.SpecialCells(xlCellTypeFormulas, xlNumbers) For Each rCell In Union(Intersect(Wrange, RS), Intersect(Wrange, Rf)) If Not IsEmpty(rCell) Then rCell.EntireRow.Hidden = IIf(rCell.Value = 0, True, False) Next rCell End With
RAN, простите, не очень понял о чем Вы)) Если в 1 000 000 строк есть "0" и "1", то их нужно обработать, и это будет долго. bmv98rus, подскажите, что означают эти строчки [vba]
Код
Set RS = .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) Set Rf = .Cells.SpecialCells(xlCellTypeFormulas, xlNumbers)
[/vba] В смысле, для чего они.
RAN, простите, не очень понял о чем Вы)) Если в 1 000 000 строк есть "0" и "1", то их нужно обработать, и это будет долго. bmv98rus, подскажите, что означают эти строчки [vba]
Код
Set RS = .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) Set Rf = .Cells.SpecialCells(xlCellTypeFormulas, xlNumbers)
Согласен, так будет быстрее - не нужно открывать единички. Я это понял пока работал идеей, осенивший на ночь глядя:
[vba]
Код
Dim r As Range, rFind As Range Dim s s = Timer With ActiveSheet.UsedRange Set r = ActiveSheet.Cells(.Row - 1, 14).Resize(.Rows.Count + 1) End With r.EntireRow.Hidden = False Set rFind = r.Find(What:="0", After:=r.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole) If rFind Is Nothing Then Exit Sub Do rFind.EntireRow.Hidden = True Set rFind = r.Find(What:="0", After:=rFind, LookIn:=xlValues, LookAt:=xlWhole) Loop While Not rFind Is Nothing Debug.Print Timer - s
[/vba]
На 20 000 строк прирост в скорости 3,47998 против 5,432129
Согласен, так будет быстрее - не нужно открывать единички. Я это понял пока работал идеей, осенивший на ночь глядя:
[vba]
Код
Dim r As Range, rFind As Range Dim s s = Timer With ActiveSheet.UsedRange Set r = ActiveSheet.Cells(.Row - 1, 14).Resize(.Rows.Count + 1) End With r.EntireRow.Hidden = False Set rFind = r.Find(What:="0", After:=r.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole) If rFind Is Nothing Then Exit Sub Do rFind.EntireRow.Hidden = True Set rFind = r.Find(What:="0", After:=rFind, LookIn:=xlValues, LookAt:=xlWhole) Loop While Not rFind Is Nothing Debug.Print Timer - s
[/vba]
На 20 000 строк прирост в скорости 3,47998 против 5,432129Mikael
Mikael, Если замените r.Find на загрузку в массив, перебор и удаление будет еще быстрее, а если скрыть в конце ( то есть накопить что скрывать и разом удалить ,может выйти еще лучше.
Mikael, Если замените r.Find на загрузку в массив, перебор и удаление будет еще быстрее, а если скрыть в конце ( то есть накопить что скрывать и разом удалить ,может выйти еще лучше.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Mikael, Find медленно работает при многократном запуске, нужно использовать что-нибудь другое, например массив (в посте 11 об этом ужу упоминалось):
[vba]
Код
Sub Скрыть_показать()
Dim rng As Range, arr(), i As Long Dim s
s = Timer
Application.ScreenUpdating = False Set rng = ActiveSheet.usedrange.Columns("N") rng.EntireRow.Hidden = False arr() = rng.Value For i = 3 To UBound(arr) If arr(i, 1) = 0 Then rng.EntireRow.Hidden = True End If Next i Application.ScreenUpdating = True
Debug.Print Timer - s
End Sub
[/vba]
Mikael, Find медленно работает при многократном запуске, нужно использовать что-нибудь другое, например массив (в посте 11 об этом ужу упоминалось):
[vba]
Код
Sub Скрыть_показать()
Dim rng As Range, arr(), i As Long Dim s
s = Timer
Application.ScreenUpdating = False Set rng = ActiveSheet.usedrange.Columns("N") rng.EntireRow.Hidden = False arr() = rng.Value For i = 3 To UBound(arr) If arr(i, 1) = 0 Then rng.EntireRow.Hidden = True End If Next i Application.ScreenUpdating = True
будет быстрее, но в скрытии строк самое долгое - скрытие строки - все остальное относительно быстро. Ускорить можно одновременным скрытием массива строк. Например так: [vba]
Код
Sub d() Dim r As Range, c As Range, RH As Range Dim i&, n&, arr Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual
n = Cells(Rows.Count, 14).End(xlUp).Row Set r = Range("n2:n" & n)
For Each c In r If c = 1 Then If RH Is Nothing Then Set RH = c Else Set RH = Union(RH, c) ' =====check count=============== i = i + 1 If i = 8000 Then i = 0: RH.EntireRow.Hidden = True: Set RH = Nothing ' ==================== End If Next RH.EntireRow.Hidden = True
Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub
[/vba]
В файле сделал сравнение 3-х вариантов. На 2-х тыс. получилось: [vba]
будет быстрее, но в скрытии строк самое долгое - скрытие строки - все остальное относительно быстро. Ускорить можно одновременным скрытием массива строк. Например так: [vba]
Код
Sub d() Dim r As Range, c As Range, RH As Range Dim i&, n&, arr Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual
n = Cells(Rows.Count, 14).End(xlUp).Row Set r = Range("n2:n" & n)
For Each c In r If c = 1 Then If RH Is Nothing Then Set RH = c Else Set RH = Union(RH, c) ' =====check count=============== i = i + 1 If i = 8000 Then i = 0: RH.EntireRow.Hidden = True: Set RH = Nothing ' ==================== End If Next RH.EntireRow.Hidden = True
Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub
[/vba]
В файле сделал сравнение 3-х вариантов. На 2-х тыс. получилось: [vba]
о есть накопить что скрывать и разом удалить ,может выйти еще лучше
но что-то с мобилки написалось не так как хотел сказать :-) но если все готово и стаймером, то просто попробуйте через перебор масива с Union строк совместить. Там изменений не много, разве что предусмотреть сдвиг на начальную строку
о есть накопить что скрывать и разом удалить ,может выйти еще лучше
но что-то с мобилки написалось не так как хотел сказать :-) но если все готово и стаймером, то просто попробуйте через перебор масива с Union строк совместить. Там изменений не много, разве что предусмотреть сдвиг на начальную строкуbmv98rus
Замечательный Временно просто медведь , процентов на 20.
bmv98rus, Karataev, SLAVICK, вау, круто, очень много интересных приемов! Спасибо SLAVICK, все дело было в не выключенном обновлении экрана, я в постах оставлял только исполняющий код, а у ТСа были все отключения обновления экрана, калькуляции и прочее. У меня получилось: [vba]
Код
Slavick 0,4140625 Mikael 0,2890625 bmv98rus 0,4296875 Karataev 0,234375 ArrayUnion 0,3828125
[/vba] Метод с массивом, показывает ошеломляющую скорость, но когда пытаюсь добавить Union, результат ухудшается.
[vba]
Код
Sub ArrayUnion()
Dim rng As Range, rHide As Range, arr(), i As Long Dim s
s = Timer
Application.ScreenUpdating = False Set rng = ActiveSheet.UsedRange.Columns("N") rng.EntireRow.Hidden = False arr() = rng.Value For i = 3 To UBound(arr) If arr(i, 1) = 0 Then If rHide Is Nothing Then Set rHide = rng.Cells(i, 1) Else _ Set rHide = Union(rHide, rng.Cells(i, 1)) 'rng.Cells(i, 1).EntireRow.Hidden = True End If Next i rHide.EntireRow.Hidden = True Application.ScreenUpdating = True
Debug.Print "ArrayUnion "; Timer - s
End Sub
[/vba]
А при увеличении строк до 6 тыс (лист2), результат с Union значительно ухудшается относительно остальных: [vba]
Код
Slavick 10,42578125 Mikael 0,765625 bmv98rus 1,332031 Karataev 0,6367188 ArrayUnion 10,12891
[/vba]
bmv98rus, Karataev, SLAVICK, вау, круто, очень много интересных приемов! Спасибо SLAVICK, все дело было в не выключенном обновлении экрана, я в постах оставлял только исполняющий код, а у ТСа были все отключения обновления экрана, калькуляции и прочее. У меня получилось: [vba]
Код
Slavick 0,4140625 Mikael 0,2890625 bmv98rus 0,4296875 Karataev 0,234375 ArrayUnion 0,3828125
[/vba] Метод с массивом, показывает ошеломляющую скорость, но когда пытаюсь добавить Union, результат ухудшается.
[vba]
Код
Sub ArrayUnion()
Dim rng As Range, rHide As Range, arr(), i As Long Dim s
s = Timer
Application.ScreenUpdating = False Set rng = ActiveSheet.UsedRange.Columns("N") rng.EntireRow.Hidden = False arr() = rng.Value For i = 3 To UBound(arr) If arr(i, 1) = 0 Then If rHide Is Nothing Then Set rHide = rng.Cells(i, 1) Else _ Set rHide = Union(rHide, rng.Cells(i, 1)) 'rng.Cells(i, 1).EntireRow.Hidden = True End If Next i rHide.EntireRow.Hidden = True Application.ScreenUpdating = True
Debug.Print "ArrayUnion "; Timer - s
End Sub
[/vba]
А при увеличении строк до 6 тыс (лист2), результат с Union значительно ухудшается относительно остальных: [vba]
Код
Slavick 10,42578125 Mikael 0,765625 bmv98rus 1,332031 Karataev 0,6367188 ArrayUnion 10,12891
Раз пошла такая пьянка, и я мяукну. Slavick 0,43359375 Mikael 0,546875 bmv98rus 0,9492188 Karataev 0,46875 ArrayUnion 0,4609375 Мяу 0,1054688 [vba]
Код
Sub Мяу() Dim oDic As Object, ar1, ar2() Dim i&, k&, n& Dim t! t = Timer Cells.EntireRow.Hidden = False n = Cells(Rows.Count, 14).End(xlUp).Row ar1 = Range("n1:n" & n).Value
Set oDic = CreateObject("Scripting.Dictionary") With oDic For i = 1 To UBound(ar1) If ar1(i, 1) = 1 Then .Item(ar1(i, 1)) = .Item(ar1(i, 1)) & "," & "A" & i If Len(.Item(ar1(i, 1))) > 200 Then ReDim Preserve ar2(k) ar2(k) = Mid(.Item(ar1(i, 1)), 2) .Item(ar1(i, 1)) = "" k = k + 1 End If Next End With Application.ScreenUpdating = False For i = LBound(ar2) To UBound(ar2) Range(ar2(i)).EntireRow.Hidden = True Next Debug.Print "Мяу "; Timer - t
End Sub
[/vba] На Лист2 Slavick 9,109375 Mikael 1,625 bmv98rus 2,9375 Karataev 1,417969 ArrayUnion 8,917969 Мяу 0,3164063
Раз пошла такая пьянка, и я мяукну. Slavick 0,43359375 Mikael 0,546875 bmv98rus 0,9492188 Karataev 0,46875 ArrayUnion 0,4609375 Мяу 0,1054688 [vba]
Код
Sub Мяу() Dim oDic As Object, ar1, ar2() Dim i&, k&, n& Dim t! t = Timer Cells.EntireRow.Hidden = False n = Cells(Rows.Count, 14).End(xlUp).Row ar1 = Range("n1:n" & n).Value
Set oDic = CreateObject("Scripting.Dictionary") With oDic For i = 1 To UBound(ar1) If ar1(i, 1) = 1 Then .Item(ar1(i, 1)) = .Item(ar1(i, 1)) & "," & "A" & i If Len(.Item(ar1(i, 1))) > 200 Then ReDim Preserve ar2(k) ar2(k) = Mid(.Item(ar1(i, 1)), 2) .Item(ar1(i, 1)) = "" k = k + 1 End If Next End With Application.ScreenUpdating = False For i = LBound(ar2) To UBound(ar2) Range(ar2(i)).EntireRow.Hidden = True Next Debug.Print "Мяу "; Timer - t
End Sub
[/vba] На Лист2 Slavick 9,109375 Mikael 1,625 bmv98rus 2,9375 Karataev 1,417969 ArrayUnion 8,917969 Мяу 0,3164063RAN
Быть или не быть, вот в чем загвоздка!
Сообщение отредактировал RAN - Пятница, 19.01.2018, 14:04
там у меня сбрасыватель стоит на 8000 - если его уменьшить до 500 - то мой вариант на порядок шустрее . А вариант с ArrayUnion - не на много будет шустрее первого(если также поставить сбросы).
Sub Slavick_ArrayAndDic() Dim rng As Range, rHide As Range, arr(), i As Long Dim s, dic As Object, n& Dim rrr As Ranges Set dic = CreateObject("Scripting.Dictionary") Cells.EntireRow.Hidden = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual s = Timer Set rng = ActiveSheet.UsedRange.Columns("N") n = rng.Row arr() = rng.Value For i = 1 To UBound(arr) If arr(i, 1) = 0 Then dic(i + n - 1) = i + n - 1 ' =====check count=============== ii = ii + Len(Format(i + n, 0)) + 2 If ii >= 250 Then ii = 0 Range("A" & Join(dic.keys, ",A")).EntireRow.Hidden = True dic.RemoveAll End If ' ==================== End If Next i Range("A" & Join(dic.keys, ",A")).EntireRow.Hidden = True Debug.Print "Slavick_ArrayAndDic "; Format(Timer - s, "0.0000") Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
[/vba]
Сравнение 2-го листа(1-й даже не интересно смотреть): [vba]
там у меня сбрасыватель стоит на 8000 - если его уменьшить до 500 - то мой вариант на порядок шустрее . А вариант с ArrayUnion - не на много будет шустрее первого(если также поставить сбросы).
Sub Slavick_ArrayAndDic() Dim rng As Range, rHide As Range, arr(), i As Long Dim s, dic As Object, n& Dim rrr As Ranges Set dic = CreateObject("Scripting.Dictionary") Cells.EntireRow.Hidden = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual s = Timer Set rng = ActiveSheet.UsedRange.Columns("N") n = rng.Row arr() = rng.Value For i = 1 To UBound(arr) If arr(i, 1) = 0 Then dic(i + n - 1) = i + n - 1 ' =====check count=============== ii = ii + Len(Format(i + n, 0)) + 2 If ii >= 250 Then ii = 0 Range("A" & Join(dic.keys, ",A")).EntireRow.Hidden = True dic.RemoveAll End If ' ==================== End If Next i Range("A" & Join(dic.keys, ",A")).EntireRow.Hidden = True Debug.Print "Slavick_ArrayAndDic "; Format(Timer - s, "0.0000") Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
[/vba]
Сравнение 2-го листа(1-й даже не интересно смотреть): [vba]
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
[/offtop]
- все остальное относительно быстро.
