Sorting and Deleting VBA for large file

[heathball]

Eventually settled on this vba recording, as it was the best result i could achieve when looking for this goal-
Delete rows that have TRUE in column B.

806,352 rows, 160 columns. ("A:FD")
Anything with filter/delete was horrible. A "delete row if cell matches TRUE" did not work at all.

This method below is what one would do on excel without VBA, for easy deletion, and is not much quicker.
(sort the true/false, so the TRUE can be deleted seperately)

But i thought i would try to find out if Google is keeping something from me, as i need to do this quite often in the near future.
Is there a way to use some combination of FILTERS/SORT/DELETE, that results in something smoother than excel functions?

The sort column "B" only has TRUE/FALSE >> does that mean a relatively simple ARRAY code could help?

Thanks in advance.

  ActiveWorkbook.Worksheets("sheet5").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("sheet5").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("b:b"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("sheet5").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
  Columns("B:B").Select
 Selection.Find(What:="true", after:=ActiveCell, LookIn:=xlFormulas2, _
       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
       MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.EntireRow.Select
  Range(Selection, Selection.End(xlDown)).Delete

 

[Akuini]

It's probably the formula calculation that makes the sorting takes longer.
Try this:

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

 ActiveWorkbook.Worksheets("sheet5").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("sheet5").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("b:b"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("sheet5").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
  Columns("B:B").Select
 Selection.Find(What:="true", after:=ActiveCell, LookIn:=xlFormulas2, _
       LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
       MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.EntireRow.Select
  Range(Selection, Selection.End(xlDown)).Delete

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic

 

[Akuini]

One more thing:

LookIn:=xlFormulas2

Why are you looking it in the formula? I think it should be xlValues.

 

[heathball]

Thanks for replying Akuini,
I don't have formulas in the file.
I use manual calculation.
I cannont identify an issue with looking through the formulas search for a value.
I switched it and it was the same time taken for the macro. the slow issue is with the sorting (or filtering)

Perhaps i might stick with this option for a while and see if something comes up later.
Cheers

 

[RobP]

Hi, how long does this sort take ?

Sub sorting()
 Dim rg As Range
 Dim my_arr, new_arr As Variant
 Dim row_search As Long
 
  
 Lastrow = Sheets("Sheet5").Cells(Rows.Count, 2).End(xlUp).Row
    Set rg = Range("A3:FD" & Lastrow) ' you need to correct for where your data starts if not in A3
    rg.Sort rg.Columns("B"), xlAscending

   
End Sub

 

[heathball]

Hi, how long does this sort take ?

Sub sorting()
 Dim rg As Range
 Dim my_arr, new_arr As Variant
 Dim row_search As Long
 
 
 Lastrow = Sheets("Sheet5").Cells(Rows.Count, 2).End(xlUp).Row
    Set rg = Range("A3:FD" & Lastrow) ' you need to correct for where your data starts if not in A3
    rg.Sort rg.Columns("B"), xlAscending

  
End Sub

Hello Rob
around 45 seconds.
But it is simpler and smoother, so it is my new sort code .Thanks.

your code produced approx the same result. 45 secs.

I see you have referenced a Variant (my_arr)
but I don't see it in the code itself.
Is it operating in the code?

 

[RobP]

you're welcome. 800,000 rows is quite a lot of data ... you sure you don't need a database

sorry I was playing a little with a few things .. and forgot to remove it from my post - so you can erase it.

Rgds
Rob

 

[Phuoc]

Try this code:

Sub abc()
Dim rng As Range, i As Long, lr As Long
Dim t
t = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
lr = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lr
    If Range("B" & i).Value = "True" Then
        If rng Is Nothing Then
            Set rng = Range("B" & i)
        Else
            Set rng = Union(rng, Range("B" & i))
        End If
    End If
Next i
If rng Is Nothing Then rng.EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
MsgBox Timer - t
End Sub

 

[Alex Blakenburg]

I don't have formulas in the file.

Based on the above, this should be faster.
Note: I have assumed a heading row in row 1 and the data starting at row 2

Sub RemoveRowsWithTrue()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim arrOrig As Variant, arrNew As Variant
    Dim i As Long, j As Long, iNew As Long
    
    Set ws = Worksheets("Sheet5")           ' <--- Change as required
    With ws
        lastRow = .Range("B" & Rows.Count).End(xlUp).Row
        Set rng = .Range(.Cells(2, "A"), .Cells(lastRow, "FD"))
        arrOrig = rng.Value2
    End With
    
    ReDim arrNew(1 To UBound(arrOrig, 1), 1 To UBound(arrOrig, 2))
    
    For i = 1 To UBound(arrOrig)
        If StrComp(arrOrig(i, 2), True, vbTextCompare) <> 0 Then
            iNew = iNew + 1
            For j = 1 To UBound(arrOrig, 2)
                arrNew(iNew, j) = arrOrig(i, j)
            Next j
        End If
    Next i

    rng.ClearContents
    rng.Resize(iNew, UBound(arrNew, 2)).Value2 = arrNew
    
    ' Reset Used Range
    Dim tmp As String
    tmp = ws.UsedRange.Address
End Sub

 

[heathball]

Try this code:

Sub abc()
Dim rng As Range, i As Long, lr As Long
Dim t
t = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
lr = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lr
    If Range("B" & i).Value = "True" Then
        If rng Is Nothing Then
            Set rng = Range("B" & i)
        Else
            Set rng = Union(rng, Range("B" & i))
        End If
    End If
Next i
If rng Is Nothing Then rng.EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
MsgBox Timer - t
End Sub

thanks Phuoc,
this is the debug