Hello I am wondering if anyone has any suggestions for a replacement for a Do Until loop in VBA??

My Code (see below), basically looks at cell F4, if Cell F4 is 0 then the row is selected and deleted. the cells then shift up, it loops again until the F4 is either greater than zero or it is empty.

The code actually works perfectly well but it takes an age to finish (around 3 mins at a guess). I do make sure that screen updating is turned off etc, I just haven't included that in this example.

I am not to fussed that it takes so long in the first instance but eventually it will doing this search multiple times in one hit, potentially up to 10K cells at a time so I want it to be a bit more snappy...

So my question is is there anything I can do other than Do until loops?

Do Until Raw1.Range("F4") = "" Or Raw1.Range("F4") > 0
    If Raw1.Range("F4").Value = 0 Then
        Raw1.Range("A4:H4").Select
        Selection.Delete Shift:=xlUp
    End If
Loop

CodePudding user response：

Delete Data Using AutoFilter

• Starting from row 4 (the header row is 3), this will delete all consecutive A:H row ranges, whose cell values in column F are equal to 0 (preserving blank cells).

Option Explicit

Sub DeleteZeros()
' 'Raw1' is the code name of a worksheet in the workbook containing this code.
    
    Const FirstCellAddress As String = "F3"
    Const ColumnsAddress As String = "A:H"
    
    If Raw1.FilterMode Then Raw1.ShowAllData
    
    Dim crg As Range ' Column Range (Has Headers - 'F')
    With Raw1.Range(FirstCellAddress)
        Dim lRow As Long
        lRow = Raw1.Cells(Raw1.Rows.Count, .Column).End(xlUp).Row
        Dim rCount As Long: rCount = lRow - .Row   1
        If rCount < 2 Then Exit Sub ' to few rows
        Set crg = .Resize(rCount)
    End With
    
    Dim drg As Range ' Data Range (No Headers - 'A:H')
    With crg
        Set drg = .Resize(rCount - 1).Offset(1) _
            .EntireRow.Columns(ColumnsAddress)
    End With
    Dim FirstDataRow As Long: FirstDataRow = drg.Row
    
    ' Filter Column Range
    crg.AutoFilter 1, "0"
    
    Dim vdrg As Range ' Visible Data Range (No Headers - 'A:H')
    On Error Resume Next
        Set vdrg = drg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    Raw1.AutoFilterMode = False
    
    ' Delete
    If vdrg Is Nothing Then Exit Sub
    If vdrg.Cells(1).Row <> FirstDataRow Then Exit Sub
    vdrg.Areas(1).Delete xlShiftUp
            
End Sub

CodePudding user response：

It is always a better solution to delete from bottom up then from top down.

Sub deleteRows()

Const checkColumn As Long = 6   'Column F

Dim rg As Range
'!!!!!you will have to adjust this to your needs!!!!
Set rg = ActiveSheet.Cells(checkColumn, 4).CurrentRegion

Dim cntRows As Long
cntRows = rg.Rows.Count

Dim i As Long
For i = cntRows To 1 Step -1
    If rg.Cells(i, checkColumn) = 0 Then
        'rg.Rows(i).EntireRow.Delete xlShiftUp    'removes entire row
         rg.Rows(i).Delete xlShiftUp              'removes only columns A-H
    End If
Next
End Sub

CodePudding user response：

It is faster to delete all the cells in 1 operation. In my example code, I have a runner find the last valid cell. I use that cell to determine the size of range that needs to be deleted.

Sub RemoveEmptyRowsBasedOnColumnValues()
    Dim CalculationMode As XlCalculation
    CalculationMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Application.ScreenUpdating = False
    
    Dim Cell As Range
    With Raw1
        For Each Cell In .Range("F4", .Cells(.Rows.count, "F").End(xlUp))
            If Cell.Value > 0 Then
                If Cell.Row > 3 Then
                    .Range("A4:H4").Resize(Cell.Row - 4).Delete Shift:=xlUp
                End If
                Exit For
            End If
        Next
    End With
    
    Application.Calculation = CalculationMode
End Sub

Function Raw1() As Worksheet
    Set Raw1 = ThisWorkbook.Worksheets("Raw1")
End Function