Макрос VBA для фильтрации таблицы по определенному значению ячейки и удаления всех строк

Question

Цель моего макроса состоит в том, чтобы выполнить следующие шаги: 1: таблица фильтра, смотрящая на столбец D, чтобы получить все значения «0» 2: удалить все строки со значениями «0» 3: удалить фильтр.

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

Ошибка: «Метод« Range »из oject'_Worksheet 'не выполнен

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

Вот что у меня так далеко:

Sub Delete_Zero_Rows()

Dim ws As Worksheet
  Set ws = ThisWorkbook.Worksheets("Status")
  ws.Activate

  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0
  ws.Range("B3:F1").AutoFilter Field:=4, Criteria1:="0"


  Application.DisplayAlerts = False
    ws.Range("B4:F").SpecialCells(xlCellTypeVisible).Delete
  Application.DisplayAlerts = True
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0

End Sub

Answer 1

Если вы хотите отфильтровать по столбцу «D», то это третий, когда начинается с столбца «B»

Sub Main
    With ThisWorkbook.Worksheets("Status")
        .ShowAllData
        With .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
            .AutoFilter Field:=3, Criteria1:="0"
            On Error Resume Next
            .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Delete
           On Error GoTo 0
        End With 
        .AutofilterMode = False
    End With 
End Sub

Answer 2

Изменить диапазон в массиве

• Следующий код работает, только если в диапазоне есть значения, не формулы .Если есть формулы, значения будут возвращены.

• Следующий код скопирует весь диапазон в массив, где он будет проверять каждую строку на наличие критериев и, если не найден, будет (пере) записыватьв тот же массив, что приводит к слишком большому массиву, но затем будет 1 из 3 возможных способов (cWriteDelete) выполнить обратную запись в диапазон:

  1. Будет записана пустая строка ( "") к оставшейся части массива и вставьте его обратно в диапазон.
  2. Он скопирует массив как есть в диапазон и удалит ненужные строки .
  3. Он скопирует массив как есть в диапазон и удалит ненужный диапазон .

• Почему бы не изменить размер массива?

  Массив представляет собой массив 2D , и мы не можем изменить его первое измерение ( строки ).

Код

Sub Delete_Zero_Rows()

    Const cSheet As String = "Status"       ' Worksheet Name
    Const cRange As String = "A:F"          ' Source Columns Range Address
    Const cFR As Long = 4                   ' First Row Number
    Const cCol As Variant = "E"             ' Criteria Column Letter/Number
    Const cCrit As Long = 0                 ' Criteria
    Const cWriteDelete As Long = 2          ' 1 - Write "" to array
                                            ' 2 - Delete remaining rows
                                            ' 3 - Delete remaining range

    Dim Rng As Range      ' Last Used Cell Range In Criteria Column,
                          ' Source/Target Range
    Dim vntST As Variant  ' Source/Target Array
    Dim ACC As Long       ' Array Criteria Column Number
    Dim i As Long         ' Source Array Row Counter
    Dim j As Long         ' Source/Target Array Column Counter
    Dim k As Long         ' Target Array Row Number (Counter)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    On Error GoTo ProcedureExit   ' Safely exit program.

    With ThisWorkbook.Worksheets(cSheet)

        '************************************************
        ' Last Used Cell Range in Criteria Column (Rng) '
        '************************************************

        ' Calculate Last Used Cell Range in Criteria Column.
        Set Rng = .Columns(cCol).Find("*", , xlFormulas, _
                xlWhole, xlByColumns, xlPrevious)
        ' Check if all cells in Criteria Column (cCol) are empty i.e. Last Used
        ' Cell Range in Criteria Column (Rng) is Nothing.
        If Rng Is Nothing Then  ' Inform user.
            MsgBox "No Data in Column '" & Split(.Cells(1, cCol).Address, _
                    "$")(1) & "'.", vbInformation, "Empty Column"
            GoTo ProcedureExit  ' Safely exit program.
        End If

        '******************************
        ' Source (Target) Range (Rng) '
        '******************************

        ' Calculate Source/Target Range (Rng) from Source Columns Range(cRange).
        Set Rng = .Columns(cRange).Resize(Rng.Row - cFR + 1).Offset(cFR - 1)
        ' Copy Source/Target Range (Rng) to Source/Target Array (vntST).
        vntST = Rng

        '******************************
        ' Source/Target Array (vntST) '
        '******************************

        ' Calculate Array Criteria Column Number.
        ACC = .Columns(cCol).Column
        ' Loop through rows (i) of Source/Target Array (vntST).
        For i = 1 To UBound(vntST)
            ' Check if value of current row (i) in Array Criteria Column (ACC)
            ' does not equal to Criteria  (cCrit).
            If vntST(i, ACC) <> cCrit Then
                ' Count (add 1 to) Target Array Row Number (k).
                k = k + 1
                ' Loop through columns(j) of Source/Target Array (vntST).
                For j = 1 To UBound(vntST, 2)
                    ' Write from current row(i) in column(j) to current row(k)
                    ' in column (j) of Source/Target Array (vntST).
                    ' Note: Data is being overwritten since always k <= j.
                    vntST(k, j) = vntST(i, j)
                Next
            End If
        Next
        ' Check if Target Array Row Number is equal to the number of rows in
        ' Source/Target Array (or in Source/Target Range).
        If k = UBound(vntST) Then ' or k = Rng.Rows.Count; Inform user.
            MsgBox "No cell containing '" & cCrit & "' in Column '" _
                    & Split(.Cells(1, cCol).Address, "$")(1) & "' found.", _
                    vbInformation, "Nothing Changed"
            GoTo ProcedureExit  ' Safely exit program.
        End If

        Select Case cWriteDelete
            Case 1  ' Slower version.
                ' Loop through the remaining rows (i) of Source/Target
                ' Array (vntST) starting from the current Target Array Row
                ' Number (k) increased by 1 (next).
                For i = k + 1 To UBound(vntST)
                    ' Loop through columns(j) of Source/Target Array (vntST).
                    For j = 1 To UBound(vntST, 2)
                        ' Write empty strings ("") to current row(i) in
                        ' column (j) of Source/Target Array (vntST)
                        vntST(i, j) = ""
                    Next
                Next

                '******************************
                ' Target (Source) Range (Rng) '
                '******************************

                ' Copy completely modified Source/Target Array (vntST)
                ' to Source/Target Range (Rng).
                Rng = vntST

            Case 2  ' Faster Version.

                '******************************
                ' Target (Source) Range (Rng) '
                '******************************

                ' Copy not completely modified Source/Target Array (vntST)
                ' to Source/Target Range (Rng).
                Rng = vntST

                ' Delete remaining (not modified) rows greater than current
                ' Target Array Row Number (k) increased by First Row (cFR),
                ' i.e. starting from the calculated row:
                ' (k + 1) + (cFR - 1) = k + cFR.
                .Rows(k + cFR & ":" & Rng.Rows.Count + cFR - 1).Delete

            Case 3  ' Faster Version.

                '******************************
                ' Target (Source) Range (Rng) '
                '******************************

                ' Copy not completely modified Source/Target Array (vntST)
                ' to Source/Target Range (Rng).
                Rng = vntST

                ' Delete remaining (not modified) range.
                .Columns(cRange).Resize(Rng.Rows.Count - k) _
                        .Offset(k + cFR - 1).Delete ' Clear, ClearContents
            Case Else

        End Select

    End With

ProcedureExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Answer 3

Цикл должен нормально работать с 75 000 строк.Отключение обновления экрана, чтобы ускорить его.Попробуйте это:

Sub DeleteZeroRows()
    Dim LastRow As Long, n As Long
    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For n = LastRow To 1 Step -1
        If Cells(n, 5).Value = 0 Then Cells(n, 5).EntireRow.Delete
    Next n
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

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

Также обратите внимание Cells(n, 5), где 5 - это столбец («E») и я ищу нули.