VBA - Как быстрее удалить и сохранить некоторые данные с критериями

Question

Я хотел бы спросить, есть ли лучший способ сделать этот код быстрее, потому что у меня есть данные почти на 100 тыс. Строк, и этот код работает довольно медленно.Вот подробности

У нас есть данные за два дня, A и B, которые содержатся в столбце U, один из которых всегда на один день позже другого.

Я считаю, что EarlyDay предполагает, что это A, и когда строка содержит AI, я хочу проверить, содержит ли столбец 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

Аналогично ответу Siddharth Rout , но с использованием столбца 'helper' и сортировкой для удаления строк.

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

Answer 2

Скажем, ваши данные выглядят так:

Вы упомянули, что

1. У вас 25 столбцов
2. Для раннего дня, если Col U = Early Day и Col S = AAA,BBB or CCC, то удалить его
3. Для более позднего дня, если Col U = Early Day и Col S <> AAA,BBB or CCC, то удалить его
4. , позже деньНа 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 3

Скромный рефакторинг кода: -)

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 4

Как правило, удалять строки за одну операцию намного быстрее, чем одну за другой:

РЕДАКТИРОВАТЬ: кажется, что у вас есть данные более чем за два дня ...

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