Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Скрыть строки имеющих количество выполненных работ равных 0, увеличить скорость работы макроса
 
#1
19.10.2020 12:15:15
Добрый день! Подскажите как можно увеличить скорость работы данного макроса?  Задача макроса скрывать строки с нулевыми значениями, но при этом оставляя заголовки перед позициями. Он обрабатывает по 5000-6000 строк. Это занимает примерно час времени. Возможно ли увеличить скорость работы?
Код
Dim Pos As String
Dim flag As Boolean


Sub Скрыть_только_ноль()
Application.ScreenUpdating = False
Rows.EntireRow.Hidden = False

For i = 31 To Cells(Rows.Count, 1).End(xlUp).Row

j = 1
flag = 0
'If (ActiveSheet.Cells(i, 21).Value = 0) And (ActiveSheet.CheckBoxes(1).Value = 1) Then Rows(i).EntireRow.Hidden = True     ' пробую сразу скрывать
If ActiveSheet.Cells(i, 21).Value = 0 Then Rows(i).EntireRow.Hidden = True     ' пробую сразу скрывать
If ActiveSheet.Cells(i, 21).Value = "" Then
'Pos = ActiveSheet.Cells(i, 3).Value
   Do While InStr(1, CStr(Cells(i + j, 3)), CStr(Cells(i, 3))) = "1"
  
    If Cells(i + j, 21) > 0 Then
    flag = 1
    Exit Do
    
       End If
    j = j + 1
    
 Loop
 
    If flag Then
    Rows(i).EntireRow.Hidden = False
    Else
    Rows(i).EntireRow.Hidden = True
    End If
End If


Next i
 
 
 
#2
19.10.2020 12:19:05
gmb,приложите файл пример и полный макрос
вот вариант https://www.excel-vba.ru/chto-umeet-excel/kak-obratitsya-k-diapazonu-iz-vba/
Изменено: Mershik - 19.10.2020 12:19:58
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#3
19.10.2020 12:22:37
Цитата
gmb написал:
Это занимает примерно час времени.
жестоко )
 
 
 
#4
19.10.2020 12:26:51
Mershik, удалил большую часть строк, чтобы влез в форум файл
 
 
 
#5
19.10.2020 12:32:15
gmb,
Код
Sub hide_nyli()
Dim i As Long, lr As Long, cell As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 31 To lr
If Cells(i, 21) = 0 Then
    If cell Is Nothing Then
        Set cell = Cells(i, 21)
    Else
        Set cell = Union(cell, Cells(i, 21))
    End If
End If
Next i
If Not cell Is Nothing Then cell.EntireRow.Hidden = True
End Sub
возможно так
Код
Sub hide_nyli()
Dim i As Long, lr As Long, cell As Range, cell2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 31 To lr
If Cells(i, 21) = 0 Then
    If cell Is Nothing Then
        Set cell = Cells(i, 21)
    Else
        Set cell = Union(cell, Cells(i, 21))
    End If
Else
    If cell2 Is Nothing Then
        Set cell2 = Cells(i, 21)
    Else
        Set cell2 = Union(cell2, Cells(i, 21))
    End If
End If
Next i
If Not cell Is Nothing Then cell.EntireRow.Hidden = True
If Not cell2 Is Nothing Then cell2.EntireRow.Hidden = False
End Sub
Изменено: Mershik - 19.10.2020 12:35:47
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#6
19.10.2020 12:36:53
Как минимум можно попробовать так:
Код
Dim Pos As String
Dim flag As Boolean
 
 
Sub Скрыть_только_ноль()

Dim rr As Range
Application.ScreenUpdating = False
Rows.EntireRow.Hidden = False
 
For i = 31 To Cells(Rows.Count, 1).End(xlUp).Row
    j = 1
    flag = 0
    'If (ActiveSheet.Cells(i, 21).Value = 0) And (ActiveSheet.CheckBoxes(1).Value = 1) Then Rows(i).EntireRow.Hidden = True     ' пробую сразу скрывать
    'If ActiveSheet.Cells(i, 21).Value = 0 Then
    '    'нафига?
    '    Rows(i).EntireRow.Hidden = True     ' пробую сразу скрывать
    'End If
    If ActiveSheet.Cells(i, 21).Value = "" Then
    'Pos = ActiveSheet.Cells(i, 3).Value
        Do While InStr(1, CStr(Cells(i + j, 3)), CStr(Cells(i, 3))) = "1"
            If Cells(i + j, 21) > 0 Then
                flag = 1
                Exit Do
         
            End If
            j = j + 1
        Loop
        If Not flag Then
            If rr Is Nothing Then
                Set rr = Cells(i, 1)
            Else
                Set rr = Union(rr, Cells(i, 1))
            End If
        End If
    End If
Next i

If Not rr Is Nothing Then
    rr.EntireRow.Hidden = True
End If
End Sub
хотя суть цикла Do мне лично не очень понятна. Какова цель макроса? Просто скрыть строки с 0? Может отсюда что-то подойдет? Как удалить строки по условию?
Изменено: Дмитрий(The_Prist) Щербаков - 19.10.2020 12:41:20
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#7
19.10.2020 14:32:15
Mershik, Дмитрий(The_Prist) Щербаков, Дело в том, что надо, чтобы заголовки по позициям оставались. То есть позция 8.2.2.1 с не нулевым значениям оставалась и перед ней"8" потом "8.2" потом "8.2.2" перед ней. Так как это заголовки разделов там вообще нет никаких цифр в графе объемы  
 
 
 
#8
19.10.2020 14:34:10
gmb, ну добваить проверку на пустоту и все, правда тогда буду пустые строки с разделами...
Изменено: Mershik - 19.10.2020 14:36:08
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#9
19.10.2020 15:31:11
Mershik, Так изначальный как раз в этом плане правильно все делает, просто долго
 
 
 
#10
19.10.2020 15:35:48
gmb, я понял...вообщем тогда используйте скрытие массовое а не построчное используя UNION
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#11
19.10.2020 18:43:33
Mershik, подскажите пожалуйста как должен тогда выглядеть макрос?
 
 
 
#12
19.10.2020 18:52:05
gmb, хотел вам помочь, открыл ваш файл, там куча листов, куча макросов, куча таблиц - закрыл.
Зачем нам весь этот лишний мусор в файле?
Был бы нормальный пример без лишнего мусора уже получили бы готовое решение.
А так ничего не понятно в какой таблице в каком столбце что скрывать.... Может другим нравится в 5 листах и в кучи непонятных (не имеющих отношение к теме) макросах копаться. Я пасс. Был бы нормальный пример и нормальное задание (в какой таблице, по какому признаку что нужно  сделать), помог бы.
Кстати, Мершик в сообщении №5 уже показал как работать с Union
Изменено: New - 19.10.2020 21:11:31
 
 
 
#13
19.10.2020 19:25:50
gmb, не знаю правильно ли
Код
Sub hide_nyli()
Dim i As Long, lr As Long, cell As Range, cell2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 31 To lr
If IsEmpty(Cells(i, 21)) Then
    x = Application.WorksheetFunction.SumIf(Range(Cells(i + 1, 3), Cells(lr, 3)), Cells(i, 3) & "*", Range(Cells(i + 1, 21), Cells(i, 21)))
    If x = 0 Then
    If cell Is Nothing Then
        Set cell = Cells(i, 21)
    Else
        Set cell = Union(cell, Cells(i, 21))
    End If
    Else
    If cell2 Is Nothing Then
        Set cell2 = Cells(i, 21)
    Else
        Set cell2 = Union(cell2, Cells(i, 21))
    End If
    End If
Else
    If Cells(i, 21) = 0 Then
    If cell Is Nothing Then
        Set cell = Cells(i, 21)
    Else
        Set cell = Union(cell, Cells(i, 21))
    End If
    Else
    If cell2 Is Nothing Then
        Set cell2 = Cells(i, 21)
    Else
        Set cell2 = Union(cell2, Cells(i, 21))
    End If
    End If
End If
Next i
If Not cell Is Nothing Then cell.EntireRow.Hidden = True
If Not cell2 Is Nothing Then cell2.EntireRow.Hidden = False
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
 
 
Страницы: 1
Наверх