Оптимизация быстродействия макроса по удалению строк

[Mkdir]

Добрый день.
Есть макрос на удаление строк выделенных жёлтым
Проблема в том, что таких строк может быть очень много около 25 тысяч это итоговая по документам и макрос работает долго если вообще не зависает.

Вот пример

Код: (vb)

Sub d_rows()
Dim i As Long
If (Range("type").Value <> 5) Then
    For i = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
        If Cells(i, 1).Interior.ColorIndex = 6 Then Rows(i).Delete
    Next
    
End If
End Sub

[boa]

нарушение правил форума п.4.25.
Исправьте и продолжим

[Mkdir]

Не нашёл где редактировать можно.
Вот пример

Код: (vb)

Sub d_rows()
Dim i As Long
If (Range("type").Value <> 5) Then
    For i = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
        If Cells(i, 1).Interior.ColorIndex = 6 Then Rows(i).Delete
    Next
    
End If
End Sub

[vikttur]

Предложите адекватное название темы

[Mkdir]

Предложите адекватное название темы

Готово

[Юрий М]

Что готово?

[boa]

Всегда, на всех флрумах, оформляйте код спец.тэгами
вот правка к коду которая заставит его работать быстрее

Код: (vb)

Sub d_rows()
    Dim i As Integer, LastRow As Integer
    If (Range("type").Value <> 5) Then
        With Application: .ScreenUpdating = False: .EnableEvents = False
        LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
        For i = LastRow To 1 Step -1
            If Cells(i, 1).Interior.ColorIndex = 6 Then Rows(i).Delete
        Next
        .ScreenUpdating = True: .EnableEvents = True: End With
    End If
End Sub

[Дмитрий Щербаков(The_Prist)]

Dim i As Integer

Ой-ой-ой! плохая практика при работе со строками использовать тип Integer, т.к. у него макс.значение 32767, а строк на листе минимум 65536. Можно запросто получить ошибку переполнения типа.

[boa]

Да, чё-то я протупил,
а ведь стоял же лонг...

[Юрий М]

Отключение обновление экрана даст прирост в скорости, но не радикальный. А вот если удалять не по одной строке, а сразу весь диапазон строк, подлежащих удалению,- почувствуется сразу

[boa]

Юрий,
предложите вариант кода для сравнения

[Юрий М]

Проверить не на чем, но при больших объёмах будет очень заметно.

Код: (vb)

Sub УдалениеСтрокОднимМахом()
Dim i As Long, LastRow As Long, DelRa As Range
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To LastRow
        If Cells(i, 1).Interior.ColorIndex = 6 Then
            If DelRa Is Nothing Then
                Set DelRa = Cells(i, 1)
            Else
                Set DelRa = Union(DelRa, Cells(i, 1))
            End If
        End If
    Next
    If Not DelRa Is Nothing Then DelRa.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

[Дмитрий Щербаков(The_Prist)]

На самом деле все давно придумано и описано: Как удалить строки по условию?

[boa]

Люблю проверять различные утверждения типа "все придумано"

для данного упражнения написал макросики для тестирования.
чуток подкорректировал макрос Юрия(d_rows_2), дабы Юнион уменьшить
и Юрия макрос тоже сохранил
он, кстати аналогичен варианту из "все придумано"
Желающие могут скачать файл из вложения и потестить самостоятельно...
так вот тесты не утешительные!
оказывается на большом объеме данных последовательное удаление - самое оптимальное

тестировалось на win10, excel2013 x64, i5, 4g оперативы.
результаты в секундах.

d_rows_1  - макрос из моего поста выше;
d_rows_2 - оптимизированный мною макрос Юрия;
УдалениеСтрокОднимМахом - макрос Юрия.



Подготовлено 466 строк для удаления из массива в 1 000 строк.
d_rows_1 - 0,21875
d_rows_2 - 0,1171875
УдалениеСтрокОднимМахом - 0,296875

Подготовлено 4 666 строк для удаления из массива в 10 000 строк.
d_rows_1 - 1,3125
d_rows_2 - 3,023438
УдалениеСтрокОднимМахом - 80,72656

почувствуется сразу

почуствовал...

Подготовлено 46 666 строк для удаления из массива в 100 000 строк.
d_rows_1 - 123,3047, т.е 2 минуты
d_rows_2 - 2623,789   - ~44 минуты
УдалениеСтрокОднимМахом - "залип", может попозже раздуплится, напишу результат, но пока висит уже более часа...



я, конечно, могу ошибаться, но попробуйте сами...

[Юрий М]

Странно... Всегда удаление диапазоном выигрывало по скорости с поочерёдным удалением каждой подходящей строки.
Очень долго формируется DelRa.

[Юрий М]

Проверил на 1 000 (466) строк - d_rows_2 немного выигрывает у обоих вариантов.

[RAN]

Подготовлено 466 строк для удаления из массива в 1000 строк.
DelRowsRS - 0,0859375
d_rows_1 - 0,1015625
d_rows_2 - 0,078125
delFilter - 4,867188

УдалениеСтрокОднимМахом - 0,1796875
Подготовлено 4666 строк для удаления из массива в 10000 строк.
DelRowsRS - 1
d_rows_1 - 1,296875
d_rows_2 - 3,546875
УдалениеСтрокОднимМахом - 78,05469 Снят с дистанции
delFilter - 47,90625

Подготовлено 14000 строк для удаления из массива в 30000 строк.
DelRowsRS - 9,476563
d_rows_1 - 12,92188
d_rows_2 - 76,78906 Снят с дистанции
delFilter - 141,5078 Снят с дистанции

Фильтр сильно разочаровал  

Подготовлено 46666 строк для удаления из массива в 100000 строк.
DelRowsRS - 105,1563
d_rows_1 - 138,2578

Подготовлено 93334 строк для удаления из массива в 200000 строк.
DelRowsRS - 372,1094
d_rows_1 - 525,3906

Код: (vb)

Sub delFilter()
    Dim t!, lr&
    t = Timer
    Application.ScreenUpdating = False
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    ActiveSheet.Range("A1:A" & lr).AutoFilter _
    Field:=1, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
    ActiveSheet.AutoFilter.Range.Offset(1).EntireRow.Delete
    ActiveSheet.AutoFilter.Range.AutoFilter
    Debug.Print "delFilter - " & Timer - t
    Application.ScreenUpdating = True
End Sub

Код: (vb)

Sub DelRowsRS()
    Dim lr&, n&, i&, ii&
    Dim sF$, s$, spl
    Dim k: k = 4
    Application.ScreenUpdating = False
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    n = ActiveSheet.UsedRange.Row
    s = "A"
    For i = lr To n Step -1
         If Cells(i, 1).Interior.ColorIndex = 6 Then GoSub sRange
    Next
    If Len(s) Then sF = sF & "|" & Left(s, Len(s) - 2)
    If Len(sF) Then
        spl = Split(sF, "|")
        For i = 1 To UBound(spl)
            Range(spl(i)).EntireRow.Delete
            k = k + 1
        Next
    End If
    Application.ScreenUpdating = True
    Exit Sub
sRange:
                s = s & i & ",A"
            '        =====check len===============
            ii = ii + Len(Format(i, 0)) + 2
            If ii >= 248 Then
                sF = sF & "|" & Left(s, Len(s) - 2)
                s = Left(s, Len(s) - 2)
                ii = 0
                s = "A"
            End If
            '        ====================
Return
End Sub

Комментарий администратора

убрал лишние $ в коде, чтобы код не задваивался.

[RAN]

Предыстория создания алгоритма http://www.excelworld.ru/forum/10-36917-1