Question

我想问一下是否有更好的方法来使此代码更快，因为我有近10万行的数据并且此代码工作得很慢。这是详细信息

我们有两天的数据，A和B包含在U列中，其中某一天总是比另一天晚。

我发现EarlyDay假设是A，并且当某行包含A时，我想检查S列是否包含某些值，如果是，则删除该行。另一方面，如果U列中的日期是B，那么我只想保留S具有特定值的行，并删除所有其他值。

Sub D( )
    Dim earlyDay As Date
    earlyDay = Application.WorksheetFunction.Min(Range("u:u"))

    Dim N As Long, i As Long
    N = Cells(Rows.Count, "U").End(xlUp).Row
    For i = N To 2 Step -1
        If Cells(i, "U").Value = earlyDay Then
            Select Case Cells(i, "S").Value
                Case "AAA", "BBB", "CCC"
                    Cells(i, "U").EntireRow.Delete
            End Select
        Else
            Select Case Cells(i, "S").Value
                Case "AAA", "BBB", "CCC"
                Case Else
                    Cells(i, "S").EntireRow.Delete
            End Select
        End If
    Next i
End Sub

Answer 1

假设您的数据如下所示

您提到了

您有25列
对于早期，如果Col U = Early Day和Col S = AAA,BBB or CCC然后将其删除
对于以后的日子，如果Col U = Early Day和Col S <> AAA,BBB or CCC然后将其删除
晚一天比早一天多1天。

如果上述正确，则删除后的数据将如下所示：

正如我在您的帖子下方的评论中提到的那样，使用数组会更快，我将使用这种方法。

尝试此代码。我已经注释了代码，因此您在理解它时不会遇到问题。

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim earlyDay As Date, laterDay As Date
    Dim lRow As Long, i As Long, j As Long
    Dim rng As Range, delRange As Range
    Dim tmpArray As Variant

    '~~> Change this to the relevant sheet
    Set ws = Sheet1

    With ws
        '~~> Find last row of column U
        lRow = .Range("U" & .Rows.Count).End(xlUp).Row

        '~~> Set your Early and Later day here
        earlyDay = Application.WorksheetFunction.Min(.Range("U1:U" & lRow))
        laterDay = DateAdd("d", 1, earlyDay)

        '~~> Identify your range
        Set rng = .Range("A1:Y" & lRow)

        '~~> Transfer it to array
        tmpArray = rng.Value

        '~~> Loop through the array and clear unnecessary rows
        For i = LBound(tmpArray) To UBound(tmpArray)
            If tmpArray(i, 21) = earlyDay Then
                Select Case tmpArray(i, 19)
                Case "AAA", "BBB", "CCC"
                    For j = 1 To 25
                        tmpArray(i, j) = ""
                    Next j
                End Select
            ElseIf tmpArray(i, 21) = laterDay Then
                Select Case tmpArray(i, 19)
                Case "AAA", "BBB", "CCC"
                Case Else
                    For j = 1 To 25
                        tmpArray(i, j) = ""
                    Next j
                End Select
            End If
        Next i

        '~~> Clear Sheet for pasting new output
        .Cells.ClearContents

        '~~> Transfer data from array to worksheet
        .Range("A1").Resize(UBound(tmpArray), 25).Value = tmpArray

        '~~> Find new last row
        lRow = .Range("U" & .Rows.Count).End(xlUp).Row

        '~~> Identify rows which are blank
        For i = 2 To lRow
            If Application.WorksheetFunction.CountA(.Range("A" & i & ":Y" & i)) = 0 Then
                If delRange Is Nothing Then
                    Set delRange = .Range("A" & i & ":Y" & i)
                Else
                    Set delRange = Union(delRange, .Range("A" & i & ":Y" & i))
                End If
            End If
        Next i

        '~~> Delete blank rows
        If Not delRange Is Nothing Then delRange.Delete shift:=xlUp
    End With
End Sub

Answer 2

适度的代码重构：-）

Option Explicit

Sub D()
    Dim earlyDay As Date
    earlyDay = Application.WorksheetFunction.Min(Range("u:u"))
    Dim N As Long, i As Long
    N = Cells(Rows.Count, "U").End(xlUp).Row
    Dim rng_2Del As Range    '
    For i = N To 2 Step -1
        If Cells(i, "U").Value = earlyDay Then
            Select Case Cells(i, "S").Value
                Case "AAA", "BBB", "CCC"
                    'Cells(i, "U").EntireRow.Delete
                    Set rng_2Del = App_Union(rng_2Del, Cells(i, "U"))    '
            End Select
        Else
            Select Case Cells(i, "S").Value
                Case "AAA", "BBB", "CCC"
                Case Else
                    'Cells(i, "S").EntireRow.Delete
                    Set rng_2Del = App_Union(rng_2Del, Cells(i, "U"))    '
            End Select
        End If
    Next i
    If Not rng_2Del Is Nothing Then rng_2Del.EntireRow.Delete '
End Sub

Public Function App_Union(rng_union As Range, _
                          ByVal rng As Range) _
                          As Range    ' InExSu
    If Not rng_union Is Nothing Then
        Set rng_union = Application.Union(rng_union, rng)
    Else
        Set rng_union = rng
    End If
    Set App_Union = rng_union
End Function

Answer 3

通常，在单个操作中删除行比单行删除要快得多：

编辑：似乎您有超过两天的数据...

Sub D()
    Dim earlyDay As Date, sht As Worksheet, rngDel As Range
    Dim m, theDay as Date

    Set sht = ActiveSheet
    earlyDay = Application.WorksheetFunction.Min(sht.Range("u:u"))

    Dim N As Long, i As Long
    N = sht.Cells(sht.Rows.Count, "U").End(xlUp).Row
    For i = N To 2 Step -1
        theDay = sht.Cells(i, "U").Value
        m = Application.Match(sht.Cells(i, "S").Value, _
                              Array("AAA", "BBB", "CCC"), 0)

        If (theDay = earlyDay And Not IsError(m)) Or _
           (theDay = earlyDay+1 And IsError(m))Then 

             BuildRange rngDel, sht.Cells(i, "U")

        End If

    Next i

    'delete any flagged rows
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete

End Sub

'build a range from two ranges
Sub BuildRange(rngTot As Range, rngAdd As Range)
    If Not rngTot Is Nothing Then
        Set rngTot = Application.Union(rngTot, rngAdd)
    Else
        Set rngTot = rngAdd
    End If
End Sub

Answer 4

类似于Siddharth Rout的响应，但使用“帮助程序”列并进行排序以删除行。

Option Explicit

Sub D2()


    Dim i As Long, j As Long, lc As Long, edt As Long, vals As Variant

    With Worksheets("sheet1")
    appTGGL bTGGL:=False

        edt = Application.Min(.Range("U:U"))
        lc = .Cells(1, .Columns.Count).End(xlToLeft).Column

        'store worksheet values in array
        vals = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "U").End(xlUp).Offset(0, lc - 21)).Value
        'vals = .CurrentRegion.Cells.Offset(1, 0).Value

        'add a sorting counter
        lc = UBound(vals, 2) + 1
        ReDim Preserve vals(LBound(vals, 1) To UBound(vals, 1), _
                            LBound(vals, 2) To lc)
        For i = LBound(vals, 1) To UBound(vals, 1)
            vals(i, lc) = i
        Next i

        'clear array values
        For i = LBound(vals, 1) To UBound(vals, 1)
            If vals(i, 21) = edt Then
                Select Case UCase(vals(i, 19))
                    Case "AAA", "BBB", "CCC"
                        For j = LBound(vals, 2) To UBound(vals, 2): vals(i, j) = vbNullString: Next j
                End Select
            Else
                Select Case UCase(vals(i, 19))
                    Case "AAA", "BBB", "CCC"
                    Case Else
                        For j = LBound(vals, 2) To UBound(vals, 2): vals(i, j) = vbNullString: Next j
                End Select
            End If
        Next i

        With .Cells(2, "A").Resize(UBound(vals, 1), UBound(vals, 2))

            'return values to worksheet
            .Value = vals

            'sort on the additional column
            .Cells.Sort Key1:=.Columns(lc), Order1:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlNo

        End With

        'clear the sorting index column
        .Cells(1, lc).EntireColumn.Clear

    End With

    appTGGL

End Sub

Public Sub appTGGL(Optional bTGGL As Boolean = True)
    Application.ScreenUpdating = bTGGL
    Application.EnableEvents = bTGGL
    Application.DisplayAlerts = bTGGL
    Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
    Debug.Print Timer
End Sub

VBA-如何更快地删除和保留符合条件的数据

4 个答案: