Question

我是VB的初学者，用google搜索并查看答案，我已经编写了以下循环来遍历多个excel工作表并删除单元格中包含特定元素的行（N / A＃N / A＃）。

要清理的xl工作表中的数据是DATE，OPEN的财务数据。高低关闭。行数可能很大，工作表的数量可以是2-300。它工作但非常非常慢，因为我正在学习 - 将不胜感激任何帮助我如何使这段代码更快。谢谢。

    Sub DataDeleteStage1()

    ScreenUpdating = False

      Dim lrow As Long
      Dim ws As Worksheet
      Dim icntr As Long


       For Each ws In ThisWorkbook.Worksheets

                lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row
                For icntr = lrow To 1 Step -1

                If ws.Name <> "HEADER" Then
                If ws.Cells(icntr, "B") = "#N/A N/A" And ws.Cells(icntr, "C") = "#N/A N/A" And ws.Cells(icntr, "D") = "#N/A N/A" And ws.Cells(icntr, "E") = "#N/A N/A" Then
                            ws.Rows(icntr).EntireRow.Delete
                End If
                End If

                Next icntr

        Next ws

    End Sub

Answer 1

尝试将要删除的所有MergeRng合并到Sub DataDeleteStage1() ScreenUpdating = False Dim lrow As Long Dim ws As Worksheet Dim icntr As Long Dim MergeRng As Range For Each ws In ThisWorkbook.Worksheets With ws lrow = .Cells(.Rows.Count, "A").End(xlUp).Row For icntr = lrow To 1 Step -1 If .Name <> "HEADER" Then If .Cells(icntr, "B") = "#N/A N/A" And .Cells(icntr, "C") = "#N/A N/A" And .Cells(icntr, "D") = "#N/A N/A" And .Cells(icntr, "E") = "#N/A N/A" Then If Not MergeRng Is Nothing Then Set MergeRng = Application.Union(MergeRng, .Rows(icntr)) Else Set MergeRng = .Rows(icntr) End If End If End If Next icntr ' Delete all rows at once If Not MergeRng Is Nothing Then MergeRng.Delete End With Set MergeRng = Nothing ' reset range when changing worksheets Next ws End Sub对象，然后立即将其全部删除。

<强>代码

{{1}}

Answer 2

您只能删除一次代码而不是每次都删除代码。为了使其像这样，请尝试以下方法：

Sub DataDeleteStage1()

    Application.ScreenUpdating = False

    Dim lrow        As Long
    Dim ws          As Worksheet
    Dim icntr       As Long

    Dim delRange    As Range

    For Each ws In ThisWorkbook.Worksheets

        lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row
        For icntr = lrow To 1 Step -1
            If ws.Name <> "HEADER" Then
                If ws.Cells(icntr, "B") = "#N/A N/A" And _
                    ws.Cells(icntr, "C") = "#N/A N/A" And _
                    ws.Cells(icntr, "D") = "#N/A N/A" And _
                    ws.Cells(icntr, "E") = "#N/A N/A" Then

                    If Not delRange Is Nothing Then
                        Set delRange = ws.Rows(icntr)
                    Else
                        Set delRange = Union(delRange, ws.Rows(icntr))
                    End If
                End If
            End If
        Next icntr

        If Not delRange Is Nothing Then delRange.Delete
        Set delRange = Nothing

    Next ws
End Sub

我没试过，但它应该有效。

Answer 3

我还没有通过测试，但试试这个，

Sub DataDeleteStage1()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim lrow As Long
    Dim ws As Worksheet
    Dim icntr As Long

    For Each ws In ThisWorkbook.Worksheets

        lrow = ws.Cells(Rows.CountLarge, "a").End(xlUp).Row

        If ws.Name <> "HEADER" Then
        On Error Resume Next
            Range("F1:F" & lrow).Formula = "=IF(SUMPRODUCT(--ISERROR(A1:E1))=5,NA(),"""")"
            Range("F1:F" & lrow).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete shift:=xlUp
            Range("F1:F" & lrow).Clear

        End If

    Next ws

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Answer 4

这个怎么样？

Sub DeleteRows()
Dim ws As Worksheet
With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

For Each ws In ThisWorkbook.Sheets
    If ws.Name <> "HEADER" Then
        On Error Resume Next
        ws.Columns("B:E").Replace "#N/A N/A", "=NA()"
        ws.Columns("B:E").SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete
    End If
Next ws
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Answer 5

使用AutoFilter并且没有完全循环：

Sub DataDeleteStage1()
Dim ws As Worksheet
Dim lr As Integer
Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
    With ws
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
        If ws.Name <> "HEADER" Then
            .UsedRange.AutoFilter Field:=2, Criteria1:="#N/A"
            .UsedRange.AutoFilter Field:=3, Criteria1:="#N/A"
            .UsedRange.AutoFilter Field:=4, Criteria1:="#N/A"
            .UsedRange.AutoFilter Field:=5, Criteria1:="#N/A"
            .Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlUp
        End If
    End With
Next ws
Application.ScreenUpdating = True
End Sub

对300K行的合并范围方法进行了测试 - 在执行多个工作表时，分钟更快。

通过excel中的多个工作表删除单元格的代码更快

5 个答案: