Здравствуйте. Подскажите пожалуйста, можно ли доработать макрос в приложенном файле? Макрос нашел в инете, по советам, немного доделал под себя. При запуске в рабочей таблице сильно тормозит, в приложенном файле тоже тормозит, но меньше. Может можно что-то сделать? Спасибо.
Здравствуйте. Подскажите пожалуйста, можно ли доработать макрос в приложенном файле? Макрос нашел в инете, по советам, немного доделал под себя. При запуске в рабочей таблице сильно тормозит, в приложенном файле тоже тормозит, но меньше. Может можно что-то сделать? Спасибо.Exsodus
Exsodus, В основном тормозит пересчет формул. Ну и кое какие вычисления констант нужно выносить за пределы циклов. Попробуйте подправленный вариант вашего макроса "Hidden" (таймер не стал удалять, закомментировал, вдруг вам потребуется). [vba]
Код
Sub Hidden() 'Dim t Dim i% Dim Cl As Range, Rn As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 't = Timer For i = 1 To 10 With Sheets(i) Set Rn = .Range("C5:C" & .Cells(.Rows.Count, 3).End(xlUp).Row) For Each Cl In Rn If Cl.Value = 0 Then Cl.EntireRow.Hidden = True Next End With Next i 't = Timer - t 'MsgBox t Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub
[/vba]
Exsodus, В основном тормозит пересчет формул. Ну и кое какие вычисления констант нужно выносить за пределы циклов. Попробуйте подправленный вариант вашего макроса "Hidden" (таймер не стал удалять, закомментировал, вдруг вам потребуется). [vba]
Код
Sub Hidden() 'Dim t Dim i% Dim Cl As Range, Rn As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 't = Timer For i = 1 To 10 With Sheets(i) Set Rn = .Range("C5:C" & .Cells(.Rows.Count, 3).End(xlUp).Row) For Each Cl In Rn If Cl.Value = 0 Then Cl.EntireRow.Hidden = True Next End With Next i 't = Timer - t 'MsgBox t Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub
Еще на заметку - полуавтоматический способ: выделяем нужные строки вручную с помощью поиска по Ctrl+F, скрываем одной командой VBA.
I. РУЧНАЯ ЧАСТЬ: 1. выделить колонку C 2. вызвать диалог "Найти и заменить" по Ctrl+F 3. ввести искомое значение 0 в поле "Найти" 4. нажать кнопку "Найти все" и дождаться отработки команды 5. по Ctrl+A выделить все найденные места в нижней части окна поиска 6. закрыть диалог "Найти и заменить"
II. ЧАСТЬ VBA: 1. перейти в Окно отладки редактора VBA по Alt+F11 и далее Ctrl+G 2. ввести инструкцию: [vba]
Код
Selection.EntireRow.Hidden = True
[/vba] и нажать Enter
К сожалению, не нашёл, как можно было бы ручную часть полностью автоматизировать. Поэтому способ и "полуавтоматический".
Еще на заметку - полуавтоматический способ: выделяем нужные строки вручную с помощью поиска по Ctrl+F, скрываем одной командой VBA.
I. РУЧНАЯ ЧАСТЬ: 1. выделить колонку C 2. вызвать диалог "Найти и заменить" по Ctrl+F 3. ввести искомое значение 0 в поле "Найти" 4. нажать кнопку "Найти все" и дождаться отработки команды 5. по Ctrl+A выделить все найденные места в нижней части окна поиска 6. закрыть диалог "Найти и заменить"
II. ЧАСТЬ VBA: 1. перейти в Окно отладки редактора VBA по Alt+F11 и далее Ctrl+G 2. ввести инструкцию: [vba]
Код
Selection.EntireRow.Hidden = True
[/vba] и нажать Enter
К сожалению, не нашёл, как можно было бы ручную часть полностью автоматизировать. Поэтому способ и "полуавтоматический".Gustav
Автоматический способ. Не самый быстрый (аж четверть секунды), но мне нравящийся отсутствием цикла по ячейкам. Используется SpecialCells, которому для выделения подставляется в столбце справа от UsedRange (никому не мешая) врЕменная формула, возвращающая значение 1 в нужных строчках:
Код
=ЕСЛИ(И($C5=0;НЕ(ЕПУСТО($C5)));1;"")
После выделения и скрытия строк временный столбец автоматически удаляется (исходный UsedRange восстанавливается). [vba]
Код
Sub Hidden3() Dim t, i As Integer Dim wks As Worksheet, rng As Range Application.ScreenUpdating = False t = Timer For i = 1 To 10 Set wks = Sheets(i) Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2) rng.FormulaR1C1 = "=IF(AND(RC3=0,NOT(ISBLANK(RC3))),1,"""")" On Error Resume Next rng.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Hidden = True '1 = Формулы \ Числа On Error GoTo 0 rng.EntireColumn.Delete Next i t = Timer - t Debug.Print t 'about 0,25 sec Application.ScreenUpdating = True End Sub
[/vba]
Автоматический способ. Не самый быстрый (аж четверть секунды), но мне нравящийся отсутствием цикла по ячейкам. Используется SpecialCells, которому для выделения подставляется в столбце справа от UsedRange (никому не мешая) врЕменная формула, возвращающая значение 1 в нужных строчках:
Код
=ЕСЛИ(И($C5=0;НЕ(ЕПУСТО($C5)));1;"")
После выделения и скрытия строк временный столбец автоматически удаляется (исходный UsedRange восстанавливается). [vba]
Код
Sub Hidden3() Dim t, i As Integer Dim wks As Worksheet, rng As Range Application.ScreenUpdating = False t = Timer For i = 1 To 10 Set wks = Sheets(i) Set rng = wks.UsedRange.Columns(wks.UsedRange.Columns.Count).Offset(0, 2) rng.FormulaR1C1 = "=IF(AND(RC3=0,NOT(ISBLANK(RC3))),1,"""")" On Error Resume Next rng.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Hidden = True '1 = Формулы \ Числа On Error GoTo 0 rng.EntireColumn.Delete Next i t = Timer - t Debug.Print t 'about 0,25 sec Application.ScreenUpdating = True End Sub