Самое быстрое удаление строк

Самое быстрое удаление строк, The Fastest Rows Deleting

Пользователь

Сообщений: 12060 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

30.08.2022 14:23:20

Приветствую!

Как известно, самое быстрое удаление строк - это удаление их одним блоком. Для этого удаляемые строки должны идти подряд. Достигается это проставлением критерия удаления в дополнительном столбце, сортировкой по нему и последующим удалением блока строк.
Кто не в курсе — исследование от ZVI с готовым решением, за что ему огромная благодарность.

Я же предлагаю не удалять строки, а оставить в Таблице только те, что нужны — с сохранением формул и форматирования умной таблицы. Нужно иметь в в иду, что данные ВНЕ исходной Таблицы никак затронуты не будут, а "лишние" строки Таблицы снизу будут полностью очищены методом Range.Clear. Таблица растягивается макросом под новый меньший размер.

Минус состоит только в том, что при сохранении строк и заполнении их новыми данными, пользовательское форматирование, примечания и всё такое могут потерять свою актуальность (выделять и пояснять — не то).
Решение: для выделений использовать УФ, а для комментариев - отдельный столбец. :idea:

Основным "спонсором" этого праздника является метод получения/вставки массива с учётом формул: Range.FormulaLocal, что позволяет сохранить формулы при вставке (и идентифицировать их при цикле внутри массива, если нужно).
Пример сделан на основе "Умной Таблицы", однако с обычным диапазоном всё будет ещё проще (т.к. не нужно "растягивать" диапазон объекта умной таблицы).

Получается всё быстро, легко и просто

Скрин

Файл
DelRows_TheFastest.xlsb (54.44 КБ)

Код

'Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
Sub TableReFill()
Dim x
    x = shReserve.ListObjects(1).DataBodyRange.FormulaLocal
    Application.ScreenUpdating = False
    With shTest.ListObjects(1)
        .Resize .Range.Resize(UBound(x, 1) + 1, UBound(x, 2))
        .DataBodyRange.FormulaLocal = x
    End With
    Application.ScreenUpdating = True
End Sub
'==================================================================================================
Sub RowsDelete()
Dim tbl As ListObject
Dim arr, x, t!

Set tbl = shTest.ListObjects(1)
arr = tbl.DataBodyRange.Value

t = Timer
    If Not PRDX_Arr2D_Filter(arr, x, 1, Array(1, 7), Array(100, 100), Array(3, 7)) Then MsgBox "NOTHING": Exit Sub ' Фильтруем массив по столбцам 1(=3) и 7(=7)
Debug.Print Round(Timer - t, 2), "Filter"

t = Timer
    PRDX_Table_DelRows tbl, x
Debug.Print Round(Timer - t, 2), "DelRows"
End Sub
'==================================================================================================
Function PRDX_Table_DelRows(tbl As ListObject, aRowsSave) As Boolean
Dim aOld, aNew(), i&, r&, c&, rNew&, rDel&
Dim AppC&, AppSU As Boolean

aOld = tbl.DataBodyRange.FormulaLocal
rNew = UBound(aRowsSave) - LBound(aRowsSave) + 1: rDel = UBound(aOld, 1) - rNew
ReDim aNew(1 To rNew, 1 To UBound(aOld, 2))

For i = LBound(aRowsSave) To UBound(aRowsSave)
    r = r + 1
    For c = 1 To UBound(aOld, 2)
        aNew(r, c) = aOld(aRowsSave(i), c)
    Next c
Next i
aOld = 0

AppC = Application.Calculation: Application.Calculation = xlCalculationManual
AppSU = Application.ScreenUpdating: Application.ScreenUpdating = False
    tbl.Range.Cells(1, 1).Offset(rNew + 1).Resize(rDel, UBound(aNew, 2)).Clear
    tbl.Resize tbl.Range.Cells(1, 1).Resize(rNew + 1, UBound(aNew, 2))
    tbl.DataBodyRange.FormulaLocal = aNew
Application.Calculation = AppC
Application.ScreenUpdating = AppSU

PRDX_Table_DelRows = True
End Function

UPD: Функция для обычного диапазона. Передавать диапазон без заголовков

Для фильтрации массива, в качестве демонстрации работы, а также уменьшения кода, используется моя недавняя функция - таким образом, процедура удаления строк может занимать всего одну строку: If ФункцияФильтра() Then ФункцияУдаления() (в примере расписал подробнее).
Конструктивные замечания и предложения приветствуются

UPD 08/12/2022 15:00
Добавлен вариант для удаления строк с помощью моих функций умного объединения и нарезки адресов.
Добавлен очень быстрый вариант для удаления строк с помощью инструмента «Удалить дубликаты»

Изменено: Jack Famous - 08.12.2022 15:00:40

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

Jack Famous

Пользователь

Сообщений: 12060 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

08.12.2022 14:32:58

Перенесено отсюда

Тест функций умного объединения и нарезки адресов для удаления строк

Скрины

Файл
DelRows_Final.xlsb (30.24 КБ)

Коды

Модуль «PRDX»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
'==================================================================================================
'==================================================================================================
' принимает лист и строку адресов с этого листа, а заполняет массив макисмально (до 255 символов) "укрупнённых" адресов
Function PRDX_Split_AdrToArrRngs(sh As Worksheet, txAdr$) As Range()
Dim aRng_Res() As Range
Dim l&, n&, i&, p&, m&, s$

l = Len(txAdr): If l < 256 Then ReDim aRng_Res(1): Set aRng_Res(1) = sh.Range(txAdr): GoTo fin
m = l - 256: ReDim aRng_Res(l \ 100)

Do
    i = InStrRev(txAdr, ",", p + 256)
    n = n + 1: Set aRng_Res(n) = sh.Range(Mid$(txAdr, p + 1, i - p - 1))
    p = i

    If p > m Then
        n = n + 1: Set aRng_Res(n) = sh.Range(Right$(txAdr, l - p))
        ReDim Preserve aRng_Res(n): GoTo fin
    End If
Loop

fin: PRDX_Split_AdrToArrRngs = aRng_Res
End Function
'==================================================================================================
'==================================================================================================
' Функция объединяет все диапазоны переданного массива в один диапазон, который и возвращает Range
Function PRDX_Rng_UnionArray(aRng() As Range) As Range
Dim u&, n&
    Do
        For u = 1 To UBound(aRng) Step 30
            n = n + 1: Set aRng(n) = PRDX_Rng_UnionSmart(aRng, u)
        Next u
 
        ReDim Preserve aRng(n)
        If n < 31 Then Set PRDX_Rng_UnionArray = PRDX_Rng_UnionSmart(aRng): Exit Function Else n = 0
    Loop
End Function
'--------------------------------------------------------------------------------------------------
' Функция для "умного" объединения диапазонов из переданного массива с помощью Union
' Основной смысл — объединять ДО 30 диапазонов за раз (максимум для Union). Реже вызов Union = выше скорость
' Функция получает массив диапазонов и индекс элемента, с которого нужно начать объединения.
' Функция постарается максимально "забить" Union всеми 30ю аргументами-диапазонами, а, если их меньше, то всеми оставшимися
Function PRDX_Rng_UnionSmart(arrRng() As Range, Optional iStart& = 1) As Range
Dim n&

n = UBound(arrRng) - iStart + 1 ' количество элементов от стартового и до конца массива
If n > 29 Then Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26), arrRng(iStart + 27), arrRng(iStart + 28), arrRng(iStart + 29)): Exit Function

If n < 15 Then
    If n < 8 Then
        If n < 4 Then
            If n < 3 Then
                If n = 1 Then
                    Set PRDX_Rng_UnionSmart = arrRng(iStart): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1)): Exit Function
                End If
            Else
                Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2)): Exit Function
            End If
        Else
            If n < 6 Then
                If n = 4 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4)): Exit Function
                End If
            Else
                If n = 6 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6)): Exit Function
                End If
            End If
        End If
    Else
        If n < 12 Then
            If n < 10 Then
                If n = 8 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8)): Exit Function
                End If
            Else
                If n = 10 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10)): Exit Function
                End If
            End If
        Else
            If n < 14 Then
                If n = 12 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12)): Exit Function
                End If
            Else
                Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13)): Exit Function
            End If
        End If
    End If
Else
    If n < 23 Then
        If n < 19 Then
            If n < 17 Then
                If n = 15 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15)): Exit Function
                End If
            Else
                If n = 17 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17)): Exit Function
                End If
            End If
        Else
            If n < 21 Then
                If n = 19 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19)): Exit Function
                End If
            Else
                If n = 21 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21)): Exit Function
                End If
            End If
        End If
    Else
        If n < 27 Then
            If n < 25 Then
                If n = 23 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23)): Exit Function
                End If
            Else
                If n = 25 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25)): Exit Function
                End If
            End If
        Else
            If n < 29 Then
                If n = 27 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26), arrRng(iStart + 27)): Exit Function
                End If
            Else
                Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26), arrRng(iStart + 27), arrRng(iStart + 28)): Exit Function
            End If
        End If
    End If
End If

Stop: End
End Function
'==================================================================================================
'==================================================================================================

Модуль «Test»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub Test_Union_Straight()
Dim aRow&(), aAdr$(), aRng() As Range
Dim rng As Range
Dim t!, tt!
Const nAll& = 1000000                                                       ' All Timers by 1mln separate Cells

tt = Timer

t = Timer
    Get_Arrays aRow, aAdr, aRng, nAll
Debug.Print Format$(Timer - t, "0.00"), "Prepare"                           ' 3.71

t = Timer
    UnionByArr rng, aRng, , nAll
Debug.Print Format$(Timer - t, "0.00"), "Union_VBA ", rng.Count             ' 3.22, 1 000 000
Set rng = Nothing

t = Timer
    Set rng = PRDX_Rng_UnionArray(aRng)
Debug.Print Format$(Timer - t, "0.00"), "Union_Smart", rng.Count            ' 0.66, 1 000 000(x5 faster)
Set rng = Nothing

t = Timer
    Set rng = PRDX_Rng_UnionArray(PRDX_Split_AdrToArrRngs(shZero, Join(aAdr, ",")))
Debug.Print Format$(Timer - t, "0.00"), "Union_Smart+Cut", rng.Count        ' 0.72, 1 000 000(x4 faster - Not Profit)
Set rng = Nothing

Debug.Print Format$(Timer - tt, "0.00"), "DONE"
End Sub
'==================================================================================================
Sub Test_Union_Separate()
Dim aRow&(), aAdr$(), aRng() As Range, aRng_Part() As Range
Dim rng As Range
Dim adr$, t!, tt!
Const nAll& = 100000                                                            ' All Timers by 100k separate Cells

tt = Timer

t = Timer
    Get_Arrays aRow, aAdr, aRng, nAll, True
Debug.Print Format$(Timer - t, "0.00"), "Prepare"                               ' 0.38


' Union 1% ======================================

t = Timer
    UnionByArr rng, aRng, , nAll / 100
Debug.Print Format$(Timer - t, "0.00"), "Union_1%. VBA ", rng.Count             ' 0.52, 1 000
Set rng = Nothing


aRng_Part = aRng
ReDim Preserve aRng_Part(nAll / 100)

t = Timer
    Set rng = PRDX_Rng_UnionArray(aRng_Part)
Debug.Print Format$(Timer - t, "0.00"), "Union_1%. Smart", rng.Count            ' 0.01, 1 000 (x50 faster)
Set rng = Nothing


' Union 10% =====================================

't = Timer
'    UnionByArr rng, aRng, , nAll / 10
'Debug.Print Format$(Timer - t, "0.00"), "Union_10%. VBA", rng.Count          ' 513.88, 10 000 (x1000 Time by x10 Cells) - DON't DO IT!!!!!!!!!!!!!!!!!!!!!!!!
'Set rng = Nothing


aRng_Part = aRng
ReDim Preserve aRng_Part(nAll / 10)

t = Timer
    Set rng = PRDX_Rng_UnionArray(aRng_Part)
Debug.Print Format$(Timer - t, "0.00"), "Union_10%. Smart", rng.Count           ' 0.18, 10 000 (x2855 faster)
Set rng = Nothing


' Union 100% ====================================

t = Timer
    Set rng = PRDX_Rng_UnionArray(aRng)
Debug.Print Format$(Timer - t, "0.00"), "Union_100%. Smart", rng.Count          ' 19.45, 100 000
Set rng = Nothing

' Cut Address ===================================

t = Timer
    Set rng = PRDX_Rng_UnionArray(PRDX_Split_AdrToArrRngs(shZero, Join(aAdr, ",")))
Debug.Print Format$(Timer - t, "0.00"), "Union_100%. Smart+Cut", rng.Count      ' 20.06, 100 000 (Out of Frofit. Union 100k or 3k — doesn't matter)
Set rng = Nothing


' Final =========================================

Debug.Print Format$(Timer - tt, "0.00"), "DONE"
End Sub
'==================================================================================================
Sub Test_DelRows()
Dim aRow&(), aAdr$(), aRng() As Range
Dim rng As Range
Dim x, t!, tt!, n&
Const nAll& = 10000                                             ' All Timers by 10k separate Cells

tt = Timer

t = Timer
    Get_Arrays aRow, aAdr, aRng, nAll, True
Debug.Print Format$(Timer - t, "0.00"), "Prepare"               ' 0.03

Application.ScreenUpdating = False


' Run ONLY ONE Block(other - comment)
Range("A1:A" & nAll).Value2 = 1
t = Timer
    PRDX_Rng_UnionArray(aRng).EntireRow.Delete
Debug.Print Format$(Timer - t, "0.00"), "UnionSmart"            ' 6.71 (x3 faster)



'Range("A1:A" & nAll).Value2 = 1
't = Timer
'    For Each x In PRDX_Split_AdrToArrRngs(shZero, Join(aAdr, ","))
'        x.EntireRow.Delete
'    Next x
'Debug.Print Format$(Timer - t, "0.00"), "AdrCut"                ' 19.56 (no Profit)



'Range("A1:A" & nAll).Value2 = 1
't = Timer
'    For n = UBound(aRow) To 1 Step -1
'        Rows(aRow(n)).Delete
'    Next n
'Debug.Print Format$(Timer - t, "0.00"), "Simple"                ' 22.67



Application.ScreenUpdating = True
Debug.Print Format$(Timer - tt, "0.00"), "DONE"
End Sub
'==================================================================================================

Модуль «Work»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub Get_aRow(aRow&(), ByVal n&, Optional SeparateCells As Boolean)  ' 0.00 on 100k
Dim r&, rOfs&

ReDim aRow(n)
If SeparateCells Then rOfs = 2 Else rOfs = 1

For n = 1 To n
    r = r + rOfs
    aRow(n) = r
Next n
End Sub
'==================================================================================================
Sub Get_aAdr(aRow&(), aAdr$())                                      ' 0.02 on 100k
Dim n&

ReDim aAdr(UBound(aRow))

For n = 1 To UBound(aRow)
    aAdr(n) = "A" & aRow(n)
Next n
End Sub
'==================================================================================================
Sub Get_aRng(aAdr$(), aRng() As Range)                              ' 0.38 on 100k
Dim n&

ReDim aRng(UBound(aAdr))

For n = 1 To UBound(aAdr)
    Set aRng(n) = shZero.Range(aAdr(n))
Next n
End Sub
'==================================================================================================
Sub Get_Arrays(aRow&(), aAdr$(), aRng() As Range, ByVal n&, Optional SeparateCells As Boolean)
Dim r&, rOfs&

ReDim aRow(n)
ReDim aAdr(n)
ReDim aRng(n)
If SeparateCells Then rOfs = 2 Else rOfs = 1

For n = 1 To n
    r = r + rOfs
    aRow(n) = r
    aAdr(n) = "A" & r
    Set aRng(n) = shZero.Range(aAdr(n))
Next n
End Sub
'==================================================================================================
'==================================================================================================
Sub UnionByArr(rngRes As Range, aRng() As Range, Optional ByVal LB&, Optional ByVal UB&)
Dim n&

If LB = 0 Then LB = LBound(aRng)
If UB = 0 Then UB = UBound(aRng)
If LB < 1 Or UB < 1 Or LB > UB Then Stop: End

Set rngRes = aRng(LB)

For n = LB + 1 To UB
    Set rngRes = Union(rngRes, aRng(n))
Next n
End Sub
'==================================================================================================
'==================================================================================================

'==================================================================================================
'==================================================================================================

Мой SmartUnion быстрее штатного от нескольких раз до тысяч раз и далее (в моём примере для удаления 10 тыс отдельных строк даёт выигрыш в 3 раза), а нарезка строк, крайне эффективная при форматировании большого количества диапазонов, здесь совершенно не помогает…

Изменено: Jack Famous - 08.12.2022 14:45:55

Jack Famous

Пользователь

Сообщений: 12060 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

08.12.2022 14:48:57

Перенесено оттуда же

doober, SmartUnion, конечно, позволяет существенно (10 и более раз) обогнать построчное удаление, однако с методом удаления дублей соперничать не в состоянии…
А вот сам метод можно улучшить более, чем в 2 раза

Удаление строк (в примере - скрытых) с помощью инструмента «Удалить Дубликаты»

Скрин

Файл
DelRows_Hidden.xlsb (53.22 КБ)

Коды

Модуль «Test»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public aReserve
'==================================================================================================
Sub FillAndFilter(Optional Mult& = 1)
Dim aFill(), m&, n&, r&

If Mult < 1 Then Stop: End
aReserve = [_reserve].Value2
If Not IsArray(aReserve) Then Stop: End
On Error Resume Next: shZero.ShowAllData: On Error GoTo 0
shZero.Columns("A:B").ClearContents

If Mult > 1 Then
    ReDim aFill(1 + Mult * (UBound(aReserve, 1) - 1), 1)
    aFill(1, 1) = aReserve(1, 1): n = 1

    For m = 1 To Mult
        For r = 2 To UBound(aReserve, 1)
            n = n + 1: aFill(n, 1) = aReserve(r, 1)
        Next r
    Next m

    If n = UBound(aFill, 1) Then aReserve = aFill Else Stop: End
End If

shZero.Cells(1, 1).Resize(UBound(aReserve, 1), 1).Value2 = aReserve
shZero.Range("$A$1:$A$" & UBound(aReserve, 1)).AutoFilter Field:=1, Criteria1:="1"
With shZero.UsedRange: End With
End Sub
'==================================================================================================
'==================================================================================================
Sub Test_All()
Dim aAdr$()
Dim t!

Application.ScreenUpdating = False
FillAndFilter 100: t = Timer

' Choose ONE Variant ONLY (other - to comment)
' Time by Size: 'x1     x10     x100

'doober         ' 0.08  000.48  5.20
'PRDX_RD        ' 0.08  000.22  2.14


'PRDX_Cut       ' 0.31  019.50  —
'PRDX_NoCut     ' 0.34  019.27  —
'PRDX_Each      ' 1.08  182.91  —

Application.ScreenUpdating = True
t = Timer - t: With shZero.UsedRange: End With
MsgBox "DONE", vbInformation, Format$(t, "0.00 sec")
End Sub
'==================================================================================================
'==================================================================================================

Модуль «Variants»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub doober()
Dim r&, n&
Dim rng As Range, cl As Range

With shZero
    For Each cl In .Range("A2:A" & UBound(aReserve, 1)).SpecialCells(xlCellTypeVisible)
        n = n + 1
        cl.Offset(0, 1) = n
    Next cl

    On Error Resume Next: .ShowAllData: On Error GoTo 0
    .Range("A1:B" & UBound(aReserve, 1)).RemoveDuplicates Columns:=2, Header:=xlNo
    .Columns(2).ClearContents
End With
End Sub
'==================================================================================================
'==================================================================================================
Sub PRDX_RD()
Dim arr, n&

With shZero.Range("B2:B" & UBound(aReserve, 1))
    .Value2 = 1
    On Error Resume Next: shZero.ShowAllData: On Error GoTo 0
    
    arr = .Value2
    For n = 1 To UBound(arr, 1)
        If Len(arr(n, 1)) Then arr(n, 1) = n
    Next n
    .Value2 = arr
End With

shZero.Range("A1:B" & UBound(aReserve, 1)).RemoveDuplicates Columns:=2, Header:=xlNo
shZero.Columns(2).ClearContents
End Sub
'==================================================================================================
Sub PRDX_Cut()
Dim aAdr$()
Dim r&, n&

ReDim aAdr(UBound(aReserve, 1) - 1)

For r = 2 To UBound(aReserve, 1)
    If shZero.Rows(r).Hidden Then n = n + 1: aAdr(n) = "A" & r
Next r

ReDim Preserve aAdr(n)
On Error Resume Next: shZero.ShowAllData: On Error GoTo 0
PRDX_Rng_UnionArray(PRDX_Split_AdrToArrRngs(shZero, Join(aAdr, ","))).EntireRow.Delete
End Sub
'==================================================================================================
Sub PRDX_NoCut()
Dim aRng() As Range
Dim r&, n&

ReDim aRng(UBound(aReserve, 1) - 1)

For r = 2 To UBound(aReserve, 1)
    If shZero.Rows(r).Hidden Then n = n + 1: Set aRng(n) = shZero.Range("A" & r)
Next r

ReDim Preserve aRng(n)
On Error Resume Next: shZero.ShowAllData: On Error GoTo 0
PRDX_Rng_UnionArray(aRng).EntireRow.Delete
End Sub
'==================================================================================================
'==================================================================================================
Sub PRDX_Each()
Dim r&
    For r = UBound(aReserve, 1) To 2 Step -1
        If shZero.Rows(r).Hidden Then shZero.Rows(r).Delete
    Next r
End Sub
'==================================================================================================
'==================================================================================================

Нужно помнить ещё, что удаление дублей местами скидывает форматирование ячейки на Обычный стиль, а также, что в большой таблице его применение может быть затруднено или вовсе не оправдано (в то время как SmartUnion позволяет просто удалять строки, как обычно, но быстрее).

Изменено: Jack Famous - 08.12.2022 14:52:47

azma Пользователь Сообщений: 336 Регистрация: 03.12.2017	#4 08.12.2022 20:39:14 скажите пожалуйста, почему макрос PRDX_RD() ругается на ошибку тут: With shZero.Range("B2:B" & UBound(aReserve, 1)) а ошибка вот такая: Ошибка Run time error 13. Type mismatch

Jack Famous

Пользователь

Сообщений: 12060 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

08.12.2022 20:47:03

azma, shZero - кодовое имя листа в VBE. Чтобы заработало в другом файле, присвойте кодовое имя, как в моем файле или объявите одноимённую переменную листа, и присвойте ей лист:

Код
Dim shZero As Worksheet Set shZero=Worksheets("имя вашего листа")

Если же дело происходит в моём файле, значит у вас переменная aReserve не инициирована (она заполняется при автоматической подготовке данных для теста). Внимательно пройдитесь по коду теста и поймите, что он делает и в какой последовательности.

Изменено: Jack Famous - 09.12.2022 09:30:13 (Добавил решение второй возможной причины и ссылку на кодовое имя листа)

ZVI

Пользователь

Сообщений: 4435 Регистрация: 23.12.2012

08.12.2022 22:46:08

Добрый вечер, Алексей!
Хорошая тема и наработки!
Удалить скрытые ячейки (см. #3) можно по-быстрому так:

Код

Sub Zvi_ClearHidden()
  Dim i&, j&
  j = UBound(aReserve)
  With shZero.Range("A2:B" & j)
    .Columns(2).Value2 = 1
    If shZero.FilterMode Then shZero.ShowAllData
    .Sort .Cells(2), xlAscending, Header:=xlNo
    i = WorksheetFunction.Count(.Columns(2))
    .Columns(2).Resize(i).ClearContents
    .Columns(1).Offset(i).Resize(j - i).Clear
  End With
End Sub

Изменено: ZVI - 08.12.2022 23:41:18

Jack Famous

Пользователь

Сообщений: 12060 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

09.12.2022 13:43:13

ZVI, приветствую!
Большое спасибо за такую положительную оценку моих (и не только) изысканий — очень приятно :oops:

Полная очистка ячеек всё же не то же самое, что удаление строк, поэтому немного изменил ваш код и добавил к сравнению. Он быстрее примерно в 2 раза, чем мой

Дело мастера боится

Файл и Код

Файл
DelRows_Hidden.xlsb (56.11 КБ)

Код

Модуль «PRDX»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub PRDX_MsgDone(ByVal iTime!, Optional ByVal txHead$ = "DONE", Optional ByVal txMacro$, Optional ByVal iType As Byte = 64)
    If iTime > 10000 Then iTime = Timer - iTime
    If Len(txMacro) Then txMacro = " «" & txMacro & "»"
    MsgBox txHead, iType, "TimeWork of Macro" & txMacro & " is: " & Format$(iTime, "0.0 sec")
End Sub
'==================================================================================================
'==================================================================================================
Sub PRDX_Param_App_SU–Calc_KeepAndOff(AC&, ASU As Boolean)
    ASU = Application.ScreenUpdating:   If ASU Then Application.ScreenUpdating = False
    AC = Application.Calculation:       If AC <> xlCalculationManual Then Application.Calculation = xlCalculationManual
End Sub
'--------------------------------------------------------------------------------------------------
Sub PRDX_Param_App_SU–Calc_Return(AC&, ASU As Boolean)
    If Application.Calculation <> AC Then Application.Calculation = AC
    If Application.ScreenUpdating <> ASU Then Application.ScreenUpdating = ASU
End Sub
'==================================================================================================
' принимает лист и строку адресов с этого листа, а заполняет массив макисмально (до 255 символов) "укрупнённых" адресов
Function PRDX_Split_AdrToArrRngs(sh As Worksheet, txAdr$) As Range()
Dim aRng_Res() As Range
Dim l&, n&, i&, p&, m&, s$

l = Len(txAdr): If l < 256 Then ReDim aRng_Res(1): Set aRng_Res(1) = sh.Range(txAdr): GoTo fin
m = l - 256: ReDim aRng_Res(l \ 100)

Do
    i = InStrRev(txAdr, ",", p + 256)
    n = n + 1: Set aRng_Res(n) = sh.Range(Mid$(txAdr, p + 1, i - p - 1))
    p = i

    If p > m Then
        n = n + 1: Set aRng_Res(n) = sh.Range(Right$(txAdr, l - p))
        ReDim Preserve aRng_Res(n): GoTo fin
    End If
Loop

fin: PRDX_Split_AdrToArrRngs = aRng_Res
End Function
'==================================================================================================
'==================================================================================================
' Функция объединяет все диапазоны переданного массива в один диапазон, который и возвращает Range
Function PRDX_Rng_UnionArray(aRng() As Range) As Range
Dim u&, n&
    Do
        For u = 1 To UBound(aRng) Step 30
            n = n + 1: Set aRng(n) = PRDX_Rng_UnionSmart(aRng, u)
        Next u
 
        ReDim Preserve aRng(n)
        If n < 31 Then Set PRDX_Rng_UnionArray = PRDX_Rng_UnionSmart(aRng): Exit Function Else n = 0
    Loop
End Function
'--------------------------------------------------------------------------------------------------
' Функция для "умного" объединения диапазонов из переданного массива с помощью Union
' Основной смысл — объединять ДО 30 диапазонов за раз (максимум для Union). Реже вызов Union = выше скорость
' Функция получает массив диапазонов и индекс элемента, с которого нужно начать объединения.
' Функция постарается максимально "забить" Union всеми 30ю аргументами-диапазонами, а, если их меньше, то всеми оставшимися
Function PRDX_Rng_UnionSmart(arrRng() As Range, Optional iStart& = 1) As Range
Dim n&

n = UBound(arrRng) - iStart + 1 ' количество элементов от стартового и до конца массива
If n > 29 Then Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26), arrRng(iStart + 27), arrRng(iStart + 28), arrRng(iStart + 29)): Exit Function

If n < 15 Then
    If n < 8 Then
        If n < 4 Then
            If n < 3 Then
                If n = 1 Then
                    Set PRDX_Rng_UnionSmart = arrRng(iStart): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1)): Exit Function
                End If
            Else
                Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2)): Exit Function
            End If
        Else
            If n < 6 Then
                If n = 4 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4)): Exit Function
                End If
            Else
                If n = 6 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6)): Exit Function
                End If
            End If
        End If
    Else
        If n < 12 Then
            If n < 10 Then
                If n = 8 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8)): Exit Function
                End If
            Else
                If n = 10 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10)): Exit Function
                End If
            End If
        Else
            If n < 14 Then
                If n = 12 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12)): Exit Function
                End If
            Else
                Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13)): Exit Function
            End If
        End If
    End If
Else
    If n < 23 Then
        If n < 19 Then
            If n < 17 Then
                If n = 15 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15)): Exit Function
                End If
            Else
                If n = 17 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17)): Exit Function
                End If
            End If
        Else
            If n < 21 Then
                If n = 19 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19)): Exit Function
                End If
            Else
                If n = 21 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21)): Exit Function
                End If
            End If
        End If
    Else
        If n < 27 Then
            If n < 25 Then
                If n = 23 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23)): Exit Function
                End If
            Else
                If n = 25 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25)): Exit Function
                End If
            End If
        Else
            If n < 29 Then
                If n = 27 Then
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26)): Exit Function
                Else
                    Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26), arrRng(iStart + 27)): Exit Function
                End If
            Else
                Set PRDX_Rng_UnionSmart = Union(arrRng(iStart), arrRng(iStart + 1), arrRng(iStart + 2), arrRng(iStart + 3), arrRng(iStart + 4), arrRng(iStart + 5), arrRng(iStart + 6), arrRng(iStart + 7), arrRng(iStart + 8), arrRng(iStart + 9), arrRng(iStart + 10), arrRng(iStart + 11), arrRng(iStart + 12), arrRng(iStart + 13), arrRng(iStart + 14), arrRng(iStart + 15), arrRng(iStart + 16), arrRng(iStart + 17), arrRng(iStart + 18), arrRng(iStart + 19), arrRng(iStart + 20), arrRng(iStart + 21), arrRng(iStart + 22), arrRng(iStart + 23), arrRng(iStart + 24), arrRng(iStart + 25), arrRng(iStart + 26), arrRng(iStart + 27), arrRng(iStart + 28)): Exit Function
            End If
        End If
    End If
End If

Stop: End
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================

Модуль «Test»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public aReserve
'==================================================================================================
Sub FillAndFilter(Optional ByVal Mult& = 1)
Dim aFill(), m&, n&, r&
Dim t!, AC&, ASU As Boolean

t = Timer
If Mult < 1 Then Stop: End
aReserve = [_reserve].Value2
If Not IsArray(aReserve) Then Stop: End

PRDX_Param_App_SU–Calc_KeepAndOff AC, ASU
On Error Resume Next: shZero.ShowAllData: On Error GoTo 0

shZero.Rows("2:" & shZero.UsedRange.Rows.Count).Delete

If Mult > 1 Then
    ReDim aFill(1 + Mult * (UBound(aReserve, 1) - 1), 1)
    aFill(1, 1) = aReserve(1, 1): n = 1

    For m = 1 To Mult
        For r = 2 To UBound(aReserve, 1)
            n = n + 1: aFill(n, 1) = aReserve(r, 1)
        Next r
    Next m

    If n = UBound(aFill, 1) Then aReserve = aFill Else Stop: End
End If

shZero.Cells(1, 1).Resize(UBound(aReserve, 1), 1).Value2 = aReserve
shZero.Range("$A$1:$A$" & UBound(aReserve, 1)).AutoFilter Field:=1, Criteria1:="1"
With shZero.UsedRange: End With

PRDX_Param_App_SU–Calc_Return AC, ASU
PRDX_MsgDone t, "Заполнено ячеек: " & Format$(UBound(aReserve, 1), "#,##0"), "FillAndFilter"
End Sub
'==================================================================================================
'==================================================================================================
Sub Test_One()
Dim t!, AC&, ASU As Boolean

t = Timer
PRDX_Param_App_SU–Calc_KeepAndOff AC, ASU

' Choose ONE Variant ONLY (other - to comment)
' Time by Size: 'x1     x10     x100

'doober_RD      ' 0.08  000.48  5.20
'PRDX_RD        ' 0.08  000.22  2.14
'ZVI_Sort       ' 0.1   000.10  1.20

'PRDX_Cut       ' 0.31  019.50  —
'PRDX_NoCut     ' 0.34  019.27  —
'PRDX_Each      ' 1.08  182.91  —

PRDX_Param_App_SU–Calc_Return AC, ASU
t = Timer - t: With shZero.UsedRange: End With
PRDX_MsgDone t, , "Test_One"
End Sub
'==================================================================================================
'==================================================================================================

Модуль «Variants»

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub doober_RD()
Dim r&, n&
Dim rng As Range, cl As Range

With shZero
    For Each cl In .Range("A2:A" & UBound(aReserve, 1)).SpecialCells(xlCellTypeVisible)
        n = n + 1
        cl.Offset(0, 1) = n
    Next cl

    On Error Resume Next: .ShowAllData: On Error GoTo 0
    .Range("A1:B" & UBound(aReserve, 1)).RemoveDuplicates Columns:=2, Header:=xlNo
    .Columns(2).ClearContents
End With
End Sub
'==================================================================================================
Sub PRDX_RD()
Dim arr, n&

With shZero.Range("B2:B" & UBound(aReserve, 1))
    .Value2 = 1
    On Error Resume Next: shZero.ShowAllData: On Error GoTo 0
    
    arr = .Value2
    For n = 1 To UBound(arr, 1)
        If Len(arr(n, 1)) Then arr(n, 1) = n
    Next n
    .Value2 = arr
End With

shZero.Range("A1:B" & UBound(aReserve, 1)).RemoveDuplicates Columns:=2, Header:=xlNo
shZero.Columns(2).ClearContents
End Sub
'==================================================================================================
Sub ZVI_Sort()
Dim i&, j&

j = UBound(aReserve)

With shZero.Range("A2:B" & j)
    .Columns(2).Value2 = 1
    If shZero.FilterMode Then shZero.ShowAllData
    .Sort .Cells(2), xlAscending, Header:=xlNo
    i = WorksheetFunction.Count(.Columns(2))
    .Rows(i + 1 & ":" & j).Delete
    .Columns(2).ClearContents
End With
End Sub
'==================================================================================================
'==================================================================================================
Sub PRDX_Cut()
Dim aAdr$()
Dim r&, n&

ReDim aAdr(UBound(aReserve, 1) - 1)

For r = 2 To UBound(aReserve, 1)
    If shZero.Rows(r).Hidden Then n = n + 1: aAdr(n) = "A" & r
Next r

ReDim Preserve aAdr(n)
On Error Resume Next: shZero.ShowAllData: On Error GoTo 0
PRDX_Rng_UnionArray(PRDX_Split_AdrToArrRngs(shZero, Join(aAdr, ","))).EntireRow.Delete
End Sub
'==================================================================================================
Sub PRDX_NoCut()
Dim aRng() As Range
Dim r&, n&

ReDim aRng(UBound(aReserve, 1) - 1)

For r = 2 To UBound(aReserve, 1)
    If shZero.Rows(r).Hidden Then n = n + 1: Set aRng(n) = shZero.Range("A" & r)
Next r

ReDim Preserve aRng(n)
On Error Resume Next: shZero.ShowAllData: On Error GoTo 0
PRDX_Rng_UnionArray(aRng).EntireRow.Delete
End Sub
'==================================================================================================
'==================================================================================================
Sub PRDX_Each()
Dim r&
    For r = UBound(aReserve, 1) To 2 Step -1
        If shZero.Rows(r).Hidden Then shZero.Rows(r).Delete
    Next r
End Sub
'==================================================================================================
'==================================================================================================

Теперь о тестах:
• изменил процедуру наполнения и фильтрации - теперь она запрашивает множитель исходных данных (целое положительное число), я тестировал, как и ранее, на x1, x10 и x100
• тест теперь состоит из 2ух этапов: наполнение + фильтрация и запуск удаления (выбранный в коде вариант). 1ый этап запускается по даблклику в жёлтой A1, второй — в зелёной B1. Сделано это, чтобы можно было перед тестом заполнить данные вне удаляемого диапазона и посмотреть, как они меняются.
• раздельный запуск позволил выяснить интересную особенность работы удаления дублей: "удаляются" только те строки, которые относятся к диапазону удаления дублей. То есть, удаляются не строки, а ячейки (со смещением вверх) пересечения строки с диапазоном удаления. То есть, данные в "строке удаления", находящиеся ВНЕ диапазона удаления, никуда не денутся. Может быть очень удобно.
• методы успешно работают в умных таблицах (для удаления дублей в диапазон должна входить только умная таблица или её часть — диапазон для удаления дублей, состоящий из таблицы (или её части) и обычного диапазона вызовет ошибку (ожидаемо).

Изменено: Jack Famous - 09.12.2022 15:55:37

ZVI

Пользователь

Сообщений: 4435 Регистрация: 23.12.2012

09.12.2022 13:59:18

Цитата
Jack Famous написал: ...не то же самое, что удаление строк...

Алексей, хорошо, но удаление ячеек в данном случае мало чем отличается от Clear - не важно

Изменено: ZVI - 09.12.2022 14:09:53

Jack Famous

Пользователь

Сообщений: 12060 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

09.12.2022 14:16:38

Цитата
ZVI: удаление ячеек в данном случае мало чем отличается от Clear

очистка ячеек (.Clear или .ClearContents) про другое же. Для решения этой задачи могут использоваться указанные алгоритмы, но в рамках текущей задачи хотелось бы всё-таки рассмотреть именно удаление строк (или то, что даёт такой же результат).

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

Принципиальная важность удаления именно строки целиком заключается в гарантированном сохранении построчной связи данных. С помощью удаления ячеек со сдвигом или удалении дубликатов, нужно контролировать это самому (может быть полезно).

Изменено: Jack Famous - 09.12.2022 15:56:03

ZVI Пользователь Сообщений: 4435 Регистрация: 23.12.2012	#10 09.12.2022 14:25:04 Хорошо. Просто в 1-м сообщении: "...не удалять строки" и "... данные ВНЕ исходной Таблицы никак затронуты не будут, а 'лишние' строки Таблицы снизу будут полностью очищены методом Range.Clear."

Jack Famous

Пользователь

Сообщений: 12060 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

#11

09.12.2022 15:42:08

Цитата
ZVI: очищены методом Range.Clear."

ааааа

а шо ж вы ссылаетесь на #3 тогда?

Сказали бы, что это к первому методу "фильтр на месте с очищением строк вместо удаления"

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

Спасибо! :idea:

Изменено: Jack Famous - 09.12.2022 15:43:56