Excel VBA Performance - 1 миллион строк - удаление строк, содержащих значение, менее чем за 1 минуту

Ответ 1

Я предоставляю первый ответ в качестве ссылки

Другие могут оказаться полезными, если нет других доступных опций

• Самый быстрый способ добиться результата - не использовать операцию удаления
• Из 1 миллиона записей он удаляет 100 000 строк в среднем 33 секунды

.

Sub DeleteRowsWithValuesNewSheet()  '100K records   10K to delete
                                    'Test 1:        2.40234375 sec
                                    'Test 2:        2.41796875 sec
                                    'Test 3:        2.40234375 sec
                                    '1M records     100K to delete
                                    'Test 1:        32.9140625 sec
                                    'Test 2:        33.1484375 sec
                                    'Test 3:        32.90625   sec
    Dim oldWs As Worksheet, newWs As Worksheet, rowHeights() As Long
    Dim wsName As String, t As Double, oldUsedRng As Range

    FastWB True:    t = Timer

    Set oldWs = Worksheets(1)
    wsName = oldWs.Name

    Set oldUsedRng = oldWs.Range("A1", GetMaxCell(oldWs.UsedRange))

    If oldUsedRng.Rows.Count > 1 Then                           'If sheet is not empty
        Set newWs = Sheets.Add(After:=oldWs)                    'Add new sheet
        With oldUsedRng
            .AutoFilter Field:=1, Criteria1:="<>Test String"
            .Copy                                               'Copy visible data
        End With
        With newWs.Cells
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteAll                            'Paste data on new sheet
            .Cells(1, 1).Select                                 'Deselect paste area
            .Cells(1, 1).Copy                                   'Clear Clipboard
        End With
        oldWs.Delete                                            'Delete old sheet
        newWs.Name = wsName
    End If
    FastWB False:   InputBox "Duration: ", "Duration", Timer - t
End Sub

.

На высоком уровне:

• Он создает новый рабочий лист и сохраняет ссылку на начальный лист
• Столбец AutoFilters 1 по искомому тексту: .AutoFilter Field:=1, Criteria1:="<>Test String"
• Копирует все (видимые) данные с исходного листа
• Вставляет ширину, формат и данные столбцов на новый лист.
• Удаляет начальный лист
• Переименование нового листа на имя старого листа

Он использует те же вспомогательные функции, что и в вопросе

99% продолжительности используется автофильтром

.

Есть несколько ограничений, которые я нашел до сих пор, первый может быть рассмотрен:

• Если на начальном листе есть скрытые строки, он отображает их

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

• Связанный с VBA:

  • Он изменяет кодовое имя листа; другие VBA, относящиеся к Sheet1, будут разбиты (если есть)
  • Он удаляет весь код VBA, связанный с исходным листом (если есть)

.

Несколько примечаний об использовании больших файлов:

• Бинарный формат (.xlsb) резко уменьшает размер файла (от 137 Мб до 43 Мб).

• Правила неуправляемого условного форматирования могут вызывать экспоненциальные проблемы с производительностью

  • То же самое для комментариев и проверки данных

• Чтение файла или данных из сети происходит намного медленнее, чем работа с локальным файлом

Ответ 2

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

С вышеописанным как предостережение, мое решение использует AdvancedFilter объекта диапазона. Это примерно в два раза быстрее, чем DeleteRowsWithValuesNewSheet().

Public Sub ExcelHero()
    Dim t#, crit As Range, data As Range, ws As Worksheet
    Dim r&, fc As Range, lc As Range, fr1 As Range, fr2 As Range
    FastWB True
    t = Timer

        Set fc = ActiveSheet.UsedRange.Item(1)
        Set lc = GetMaxCell
        Set data = ActiveSheet.Range(fc, lc)
        Set ws = Sheets.Add
        With data
            Set fr1 = data.Worksheet.Range(fc, fc.Offset(, lc.Column))
            Set fr2 = ws.Range(ws.Cells(fc.Row, fc.Column), ws.Cells(fc.Row, lc.Column))
            With fr2
                fr1.Copy
                .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAll
                .Item(1).Select
            End With
            Set crit = .Resize(2, 1).Offset(, lc.Column + 1)
            crit = [{"Column 1";"<>Test String"}]
            .AdvancedFilter xlFilterCopy, crit, fr2
            .Worksheet.Delete
        End With

    FastWB False
    r = ws.UsedRange.Rows.Count
    Debug.Print "Rows: " & r & ", Duration: " & Timer - t & " seconds"
End Sub

Ответ 3

На моем пожилом Dell Inspiron 1564 (Win 7 Office 2007) это:

Sub QuickAndEasy()
    Dim rng As Range
    Set rng = Range("AA2:AA1000001")
    Range("AB1") = Now
    Application.ScreenUpdating = False
        With rng
            .Formula = "=If(A2=""Test String"",0/0,A2)"
            .Cells.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
            .Clear
        End With
    Application.ScreenUpdating = True
    Range("AC1") = Now
End Sub

потребовалось около 10 секунд. Я предполагаю, что имеется столбец AA.

EDIT # 1:

Обратите внимание, что этот код не выполняет не. Производительность улучшится, если для режима расчета установлено значение Ручное после, столбцу "помощник" разрешено вычислять.

Ответ 4

Я знаю, что я очень поздно опоздал с моим ответом, однако будущим посетителям может показаться, что это очень полезно.

Обратите внимание: Мой подход требует, чтобы столбец индекса для строк заканчивался в исходном порядке, однако, если вы не возражаете, чтобы строки находились в другом порядке, то индексный столбец не и дополнительная строка кода может быть удалена.

Мой подход:. Мой подход состоял в том, чтобы просто выбрать все строки в выбранном диапазоне (столбец), отсортировать их в порядке возрастания с помощью Range.Sort, а затем собрать первый и последний индекс "Test String" в пределах выбранного диапазона (столбец). Затем я создаю диапазон от первого и последнего индексов и использую Range.EntrieRow.Delete, чтобы удалить все строки, содержащие "Test String".

Плюсы:
- Он быстро вспыхивает.
- Он не удаляет форматирование, формулы, диаграммы, изображения или что-то вроде метода, который копируется на новый лист.

Минусы:
- Приличный размер кода для реализации, но все это прямолинейно.

Сегмент генерации тестового диапазона:

Sub DevelopTest()
    Dim index As Long
    FastWB True
    ActiveSheet.UsedRange.Clear
    For index = 1 To 1000000 '1 million test
        ActiveSheet.Cells(index, 1).Value = index
        If (index Mod 10) = 0 Then
            ActiveSheet.Cells(index, 2).Value = "Test String"
        Else
            ActiveSheet.Cells(index, 2).Value = "Blah Blah Blah"
        End If
    Next index
    Application.StatusBar = ""
    FastWB False
End Sub

Фильтровать и удалять строки Sub:

Sub DeleteRowFast()
    Dim curWorksheet As Worksheet 'Current worksheet vairable

    Dim rangeSelection As Range   'Selected range
    Dim startBadVals As Long      'Start of the unwanted values
    Dim endBadVals As Long        'End of the unwanted values
    Dim strtTime As Double        'Timer variable
    Dim lastRow As Long           'Last Row variable
    Dim lastColumn As Long        'Last column variable
    Dim indexCell As Range        'Index range start
    Dim sortRange As Range        'The range which the sort is applied to
    Dim currRow As Range          'Current Row index for the for loop
    Dim cell As Range             'Current cell for use in the for loop

    On Error GoTo Err
        Set rangeSelection = Application.InputBox("Select the (N=) range to be checked", "Get Range", Type:=8)    'Get the desired range from the user
        Err.Clear

    M1 = MsgBox("This is recommended for large files (50,000 or more entries)", vbYesNo, "Enable Fast Workbook?") 'Prompt the user with an option to enable Fast Workbook, roughly 150% performace gains... Recommended for incredibly large files
    Select Case M1
        Case vbYes
            FastWB True  'Enable fast workbook
        Case vbNo
            FastWB False 'Disable fast workbook
    End Select

    strtTime = Timer     'Begin the timer

    Set curWorksheet = ActiveSheet
    lastRow = CLng(rangeSelection.SpecialCells(xlCellTypeLastCell).Row)
    lastColumn = curWorksheet.Cells(1, 16384).End(xlToLeft).Column

    Set indexCell = curWorksheet.Cells(1, 1)

    On Error Resume Next

    If rangeSelection.Rows.Count > 1 Then 'Check if there is anything to do

        lastVisRow = rangeSelection.Rows.Count

        Set sortRange = curWorksheet.Range(indexCell, curWorksheet.Cells(curWorksheet.Rows(lastRow).Row, 16384).End(xlToLeft)) 'Set the sort range

        sortRange.Sort Key1:=rangeSelection.Cells(1, 1), Order1:=xlAscending, Header:=xlNo 'Sort by values, lowest to highest

        startBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, MatchCase:=False).Row
        endBadVals = rangeSelection.Find(What:="Test String", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row

        curWorksheet.Range(curWorksheet.Rows(startBadVals), curWorksheet.Rows(endBadVals)).EntireRow.Delete 'Delete uneeded rows, deleteing in continuous range blocks is quick than seperated or individual deletions.

        sortRange.Sort Key1:=indexCell, Order1:=xlAscending, Header:=xlNo 'Sort by index instead of values, lowest to highest
    End If

    Application.StatusBar = ""                    'Reset the status bar

    FastWB False                                  'Disable fast workbook

    MsgBox CStr(Round(Timer - strtTime, 2)) & "s" 'Display duration of task

Err:
    Exit Sub

End Sub

ЭТОТ КОД ИСПОЛЬЗОВАНИЯ FastWB, FastWS И EnableWS Пол Бика!

Время на 100K записей (10k для удаления, FastWB True):
1. 0,2 секунды.
2. 0,2 секунды.
3. 0,21 секунды.
Avg. 0,2 секунды.

Время на 1 миллион записей (100 000 для удаления, FastWB True):
1. 2,3 секунды.
2. 2.32 секунды.
3. 2,3 секунды.
Avg. 2,31 секунды.

Работает: Windows 10, iMac i3 11,2 (с 2010)

РЕДАКТИРОВАТЬ
Этот код был первоначально разработан с целью фильтрации числовых значений за пределами числового диапазона и был адаптирован для фильтрации "Test String", поэтому некоторые из кода могут быть избыточными.

Ответ 5

Использование вами массивов при вычислении используемого диапазона и количества строк может повлиять на производительность. Здесь другой подход, который при тестировании доказывает эффективность через 1 м + строки данных - между 25-30 секундами. Он не использует фильтры, поэтому удаляет строки, даже если они скрыты. Удаление целой строки не приведет к форматированию или ширине столбцов остальных оставшихся строк.

• Сначала проверьте, имеет ли ActiveSheet "Test String". Поскольку вас интересует только колонка 1, я использовал это:

  TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
  If TCount > 0 Then
  

• Вместо использования функции GetMaxCell() я просто использовал Cells.SpecialCells(xlCellTypeLastCell).Row для получения последней строки:

  EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
  

• Затем перебираем строки данных:

  While r <= EndRow
  

• Чтобы проверить, соответствует ли ячейка в столбце "Test String":

  If sht.Cells(r, 1).Text) = "Test String" Then
  

• Чтобы удалить строку:

  Rows(r).Delete Shift:=xlUp
  

Поместите все вместе полный код ниже. Я установил ActiveSheet в переменную Sht и добавил, что ScreenUpdating включен, чтобы повысить эффективность. Поскольку у меня много данных, я должен очистить переменные в конце.

Sub RowDeleter()
    Dim sht As Worksheet
    Dim r As Long
    Dim EndRow As Long
    Dim TCount As Long
    Dim s As Date
    Dim e As Date

    Application.ScreenUpdating = True
    r = 2       'Initialise row number
    s = Now     'Start Time
    Set sht = ActiveSheet
    EndRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row

    'Check if "Test String" is found in Column 1
    TCount = Application.WorksheetFunction.CountIf(sht.Columns(1), "Test String")
    If TCount > 0 Then

        'loop through to the End row
        While r <= EndRow
            If InStr(sht.Cells(r, 1).Text, "Test String") > 0 Then
                sht.Rows(r).Delete Shift:=xlUp
                r = r - 1
            End If
            r = r + 1
        Wend
    End If
    e = Now  'End Time
    D = (Hour(e) * 360 + Minute(e) * 60 + Second(e)) - (Hour(s) * 360 + Minute(s) * 60 + Second(s))
    Application.ScreenUpdating = True
    DurationTime = TimeSerial(0, 0, D)
    MsgBox Format(DurationTime, "hh:mm:ss")
End Sub