Question

大家好日子！

我有一个工作表，其中填充了从A列到G列的数据。每一行都是一个唯一的实体，而G列包含一个值，显示从今天起每个数据报告的数量。如果返回的值超过4（这意味着报告的日期超过了今天的4个季度），代码将删除该特定行。

目前我的代码运行了大约3分钟，我想知道是否还有其他任何我可以做的/重构我的代码以使其运行得更快。在此先感谢大家！ :)截至目前，我有大约5000行。

Sub Two_Keep3Quarters()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim lRow As Long
    Dim Tbl As ListObject
    Dim rng As Range
    Dim QuarterValue As Long

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    With Sheets("Filtered Data")
        .DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = 3
        Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'We loop from Lastrow to Firstrow (bottom to top)
        For lRow = Lastrow To Firstrow Step -1
            QuarterValue = .Range("G" & lRow).Value

            'We check the values in the Column G
            With .Cells(lRow, "G")
                If Not IsError(QuarterValue) Then
                    If QuarterValue > 4 Then .EntireRow.Delete
                    'This will delete each row with value of more than 4 quarters
                End If
            End With
        Next lRow
    End With

    Range("F1").Value = "Quarters"
    Range("G1").Value = "No. of Quarters"

    On Error Resume Next

    Set rng = Range(Range("A1"), Range("G1").End(xlDown)).SpecialCells(xlCellTypeBlanks)
    rng.Rows.Delete Shift:=xlShiftUp

    For Each Tbl In Sheets("Filtered Data").ListObjects
        Tbl.Unlist
    Next

    Set Tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Range(Range("A1"), Range("G1").End(xlDown)), , xlYes)
    With Tbl
        .Name = "DataTable"
        .TableStyle = "TableStyleLight10"
    End With

    Application.ScreenUpdating = True
End Sub

Answer 1

不要一次删除一行，而是收集所有单元格并一次删除所有单元格。

Sub Two_Keep3Quarters()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim lRow As Long
    Dim Tbl As ListObject
    Dim rng As Range
    Dim QuarterValue As Long
    Dim rngU As Range, rng As Range

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    With Sheets("Filtered Data")
        .DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = 3
        Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'We loop from Lastrow to Firstrow (bottom to top)
        For lRow = Lastrow To Firstrow Step -1

            QuarterValue = .Range("G" & lRow).Value

            'We check the values in the Column G
            With .Cells(lRow, "G")
                If Not IsError(QuarterValue) Then
                    'If QuarterValue > 4 Then .EntireRow.Delete
                    'This will delete each row with value of more than 4 quarters
                    If QuarterValue > 4 Then
                        Set rng = .Range("G" & lRow)
                        If rngU Is Nothing Then
                            Set rngU = rng
                        Else
                            Set rngU = Unoin(rngU, rng) '<~~ collect the cells
                        End If
                    End If '<~~ missed
                End If 
            End With
        Next lRow
        If rngU Is Nothing Then
        Else
            rngU.EntireRow.Delete '<~~ collect all the cells and delete them all at once.
        End If
    End With

    Range("F1").Value = "Quarters"
    Range("G1").Value = "No. of Quarters"

    On Error Resume Next

    Set rng = Range(Range("A1"), Range("G1").End(xlDown)).SpecialCells(xlCellTypeBlanks)
    rng.Rows.Delete Shift:=xlShiftUp

    For Each Tbl In Sheets("Filtered Data").ListObjects
        Tbl.Unlist
    Next

    Set Tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Range(Range("A1"), Range("G1").End(xlDown)), , xlYes)
    With Tbl
        .Name = "DataTable"
        .TableStyle = "TableStyleLight10"
    End With

    Application.ScreenUpdating = True
End Sub

让我的代码更快的提示

1 个答案: