Excel VBA Delete Visible Cells Big Data

[Biz]

Dear Sir/Madam,

I have about 1M rows. After filtering I have about 150K areas.
Deleting the visible cells after filtering is not working.

Dim aStartTime
Const DblSpace As String = vbNewLine & vbNewLine
Const CoName As String = "Silence"


Dim wbTarget As Worksheet
Dim bErrorHandle As Boolean
Sub Test()
    Dim Rng As Range, rngNew As Range, rngVis As Range, rCells As Range
    Dim area As Range
    Dim areaCount As Long


    Dim selectedRange As Range
    
    '    '~~> Speeding Up VBA Code
    Call SpeedUp(False)
    
    
    Set selectedRange = Range("A3:A600000").SpecialCells(xlCellTypeVisible)
    
    Set wbTarget = Sheets("Test")
    Set Rng = wbTarget.Range("$A$2:$L$600000")
    Set rngNew = Rng.Resize(Rng.Rows.Count - 1, 1).Offset(1, 0)


    
    
    
     areaCount = 1


    Debug.Print "# of Area(s):";
    If selectedRange.Areas.Count = 1 Then
        Debug.Print 1
        For Each rCells In selectedRange 'loop through each cell in the selected range
            Debug.Print rCells.Address 'do whatever
        Next
    Else
        Debug.Print selectedRange.Areas.Count
        For Each area In selectedRange 'more than 1 selected area
        Debug.Print "Area#: " & areaCount
        If rngVis Is Nothing Then
                Set rngVis = area
            Else
                Set rngVis = Application.Union(rngVis, area)
            End If
    
     
        rngVis.EntireRow.Delete
        
        
        '    '~~> Speeding Up VBA Code
    Call SpeedUp(True)
   
   
   If bErrorHandle = False Then
        MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & vbNewLine _
            & DblSpace & " You're good to go!" & DblSpace & _
            CoName & Chr(32) & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
    End If
        
    End Sub




'#### SpeedUp (False) - Speeds the VBA Code #####
'#### SpeedUp (True) - Slows down the VBA Code ####
Public Function SpeedUp(Optional bSpeed As Boolean = True)
With Application
    .ScreenUpdating = bSpeed 'Prevent screen flickering
    .Calculation = IIf(bSpeed, xlAutomatic, xlCalculationManual) 'Preventing calculation
    .DisplayAlerts = bSpeed 'Turn OFF alerts
    .EnableEvents = bSpeed 'Prevent All Events
    '.Cursor = IIf(bSpeed, xlDefault, xlWait) 'Prevent Hour Glass
    '.StatusBar = IIf(bSpeed, vbNullString, "Please wait...")
End With
End Function

Your help would be greatly appreciated.

Kind Regards

Biz

 

[Joe4]

Yes, I believe filters may have issues when the size of the data exceeds a certain numbers (I believe it is 10,000 unique entries).
See here for a workaround: http://www.contextures.com/xlautofilter02.html#Limits

Another option (and the one that I might use) would be to try to use Microsoft Access to do it.

 

[Peter_SSs]

In many cases the desired result can be achieved relatively quickly without filtering. Can you explain about the layout of the worksheet and what the filtering is so that an alternative can be considered?

 

[Biz]

Hi,
I'm filtering by customer numbers and making adjustments. After adjustments have been made then later on I delete all customers with adjustments in one hit. Hence, I have too many areas over large data set.

I have my data range Range("A3:A600000"). Column A has customer number.


Hope it makes sense.

Kind Regards

Biz

 

[Peter_SSs]

Give this a try. From looking at your post #1 code (which doesn't compile) I have assumed that your data is in columns A:L down to row 600,000 with your AutoFilter headings in row 2.
I have also assumed that
- column M is available to use as a helper column.
- you wouldn't be running the code if there wasn't a mix of hidden and visible rows in the range in question due to AutoFilter (otherwise the code would need some further checks to stop it possibly erroring)

For me, with 600,000 rows, no formulas in the sheet and about 133,000 visible areas in the AutoFilter this code took less than 5 seconds to complete.

Sub DeleteVisibleRows()
  Dim a As Variant
  Dim lScreenUpdating As Long, lCalculation As Long, lEnableEvents As Long, lDisplayAlerts As Long, lc As Long, Rws As Long
  Dim r As Range
 
  With Application
    lScreenUpdating = .ScreenUpdating
    lCalculation = .Calculation
    lEnableEvents = .EnableEvents
    lDisplayAlerts = .DisplayAlerts
    .ScreenUpdating = False
    .Calculation = False
    .EnableEvents = False
    .DisplayAlerts = False
  End With
  With Range("A3:M600000")    '<- This may need to be made dynamic?
    lc = .Columns.Count
    ReDim a(.Row To .Row + .Rows.Count - 1, 1 To 1)
    For Each r In .Columns(1).SpecialCells(xlVisible)
      a(r.Row, 1) = 1
      Rws = Rws + 1
    Next r
    .Parent.ShowAllData
    .Columns(lc).Value = a
    .Sort Key1:=.Columns(lc), Order1:=xlAscending, Header:=xlNo
    .Resize(Rws).EntireRow.Delete
  End With
  With Application
    .ScreenUpdating = lScreenUpdating
    .Calculation = lCalculation
    .EnableEvents = lEnableEvents
    .DisplayAlerts = lDisplayAlerts
  End With
End Sub

 

[Biz]

Hi Peter,

My visible cells are after autofilter. Your code was excellent and also lighting fast.
I had to add comments to understand your logic.

Sub DeleteVisibleRows()
  Dim a As Variant
  Dim lScreenUpdating As Long, lCalculation As Long, lEnableEvents As Long, lDisplayAlerts As Long, lc As Long, Rws As Long
  Dim r As Range
  
 
  With Application
    lScreenUpdating = .ScreenUpdating
    lCalculation = .Calculation
    lEnableEvents = .EnableEvents
    lDisplayAlerts = .DisplayAlerts
    .ScreenUpdating = False
    .Calculation = False
    .EnableEvents = False
    .DisplayAlerts = False
  End With
  
  '~~> Range includes Helper Column
  With Range("A3:AH600000")    '<- This may need to be made dynamic?
    lc = .Columns.Count
    ReDim a(.Row To .Row + .Rows.Count - 1, 1 To 1)
    For Each r In .Columns(1).SpecialCells(xlVisible)
    '~~> Array storage visible cells using 1
      a(r.Row, 1) = 1
      Rws = Rws + 1
    Next r
    '~~> Remove all filters
    .Parent.ShowAllData
    '~~> Write 1 to helper column to denote visible cells
    .Columns(lc).Value = a
    '~~> Sort to have all visible cells at top to make deletion fast and easy
    .Sort Key1:=.Columns(lc), Order1:=xlAscending, header:=xlNo
    '~~> Delete all visible cells
    .Resize(Rws).EntireRow.Delete
  End With
  
  With Application
    .ScreenUpdating = lScreenUpdating
    .Calculation = lCalculation
    .EnableEvents = lEnableEvents
    .DisplayAlerts = lDisplayAlerts
  End With
End Sub

Last question
How can I get last column used on spreadsheet dynamically?
I usually use the custom function below, but it failed probably, because first row starts from row 2.

Last Column number in a worksheet

Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Cells(1), _
                            lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

To get column reference

Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(2, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

Thank you mate for helping me out again.

Kind Regards

Biz

 

[Peter_SSs]

How can I get last column used on spreadsheet dynamically?
I usually use the custom function below, but it failed ...

Under what circumstances does it fail?

 

[Biz]

Under current circumstances where I pass worksheet name and my last column number used is incorrect. My data range(A3:AH600000) and also the last column used is AH.

Hope it makes sense.

 

[Peter_SSs]

Under current circumstances where I pass worksheet name ...

I assume that you are actually passing a worksheet object, not just the name.

..and my last column number used is incorrect. My data range(A3:AH600000) and also the last column used is AH.

What column number is being returned?

 

[kashif.special2005]

Hi Biz,

I have around 3 lacks row and 28 column data, and I am delete the rows of certain parameter in column 6. I run this code and it is taking only 20 seconds something.

This is very vast and calculating in memory rather than sheet is always better choice.

Note:- The parameters name I am giving in a sheet, that need to check in column 6 and if found delete that row.

Sample Data:-

Name Salary Area Age Colour Fruit etc.,
F 15000 South 32 Fair Grapes etc.,
A 15000 South 32 Fair Mangoes etc.,
K 15000 South 32 Fair Banana etc.,
T 15000 South 32 Fair Apple etc.,

Criteria range values that needs to check on the column "Fruit".

Mangoes
Banana

Sub ManagingData()


    Dim rngValue As Range
    Dim iLastCol As Integer, iLoop As Integer
    Dim lLastRow As Long
    Dim varMydata As Variant
    Dim dicValues As Dictionary
    Dim dtTime As Date
    
    dtTime = Now
    
    
    Set dicValues = New Scripting.Dictionary
    Set rngValue = Sheet4.Range("A1").CurrentRegion
    
    For iLoop = 1 To rngValue.Rows.Count
        dicValues.Item(rngValue.Item(iLoop, 1).Value) = rngValue.Item(iLoop, 1).Value
    Next iLoop
    
    varMydata = Application.Run(macro:="DeleteRows", _
                                arg1:=Sheet2.Range("A1").CurrentRegion, arg2:=6, _
                                arg3:=dicValues)
        
    Sheet2.Range("A1").CurrentRegion.ClearContents
        
    Sheet2.Range("A1").Resize(UBound(varMydata, 1), UBound(varMydata, 2)).Value = varMydata


    MsgBox "Done!" & vbNewLine & "Total Time Taken:" & vbTab & Format(Now - dtTime, "hh:mm:ss")
    
End Sub

Private Function DeleteRows(rngData As Range, iDelCheckColNo As Integer, dicValues As Dictionary) As Variant
    
    Dim rng As Range
    Dim mydata As Variant, mynew() As Variant
    Dim row_insert As Long, delcount As Long, i As Long, j As Long, lLastRow As Long
    Dim iLastCol As Integer, iLoop As Integer
    Dim dtime As Date


    mydata = rngData.Value
    
    For i = LBound(mydata, 1) To UBound(mydata, 1)
        If dicValues.Exists(mydata(i, iDelCheckColNo)) Then
            mydata(i, iDelCheckColNo) = "For Delete Row"
            delcount = delcount + 1
        End If
    Next i
    
    delcount = UBound(mydata, 1) - delcount
    
    ReDim mynew(1 To delcount, 1 To rngData.Columns.Count)
    
    row_insert = 1
    
    For i = LBound(mydata, 1) To UBound(mydata, 1)
        If mydata(i, iDelCheckColNo) <> "For Delete Row" Then
            For j = LBound(mydata, 2) To UBound(mydata, 2)
                mynew(row_insert, j) = mydata(i, j)
            Next j
            row_insert = row_insert + 1
        End If
    Next i
    
    DeleteRows = mynew
    
End Function

Hope this will help.

Thanks
Kashif