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

 

[Biz]

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

Hi Kashif,

I'm not sure of worksheet defintions. Please refer below.

Sheet 4 - is criteria to delete the data
Sheet 2 - where data we want to delete

Biz

 

[Biz]

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

What column number is being returned?

Hi,

I'm passing a worksheet name. I used immediate window and got Column 29 aka AC

?LastCol(Sheets(activesheet.name))
 29 


?Col_Letter(29)
AC

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

Function Col_Letter(lngCol As Long) As String  'this is for the 2 way look up
Dim vArr
vArr = Split(Cells(2, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

Bit stumped why it's failing.

Biz

 

[Peter_SSs]

I'm passing a worksheet name.

?LastCol([COLOR="#FF0000"]Sheets(activesheet.name)[/COLOR])
 29

Actually, you are (quite correctly) passing a worksheet to the function, not the worksheet name. That is, you are passing the red part to the function and the red part is a worksheet.
Incidentally, this would be exactly the same thing.

?LastCol(ActiveSheet)

The Find method can be unpredictable (to me anyway) when dealing with a filtered sheet. Why not in this case just use your heading row to determine the last column?
That is

Function LastCol(sh As Worksheet) As Long
    LastCol = sh.Cells(2, sh.Columns.Count).End(xlToLeft).Column
End Function

BTW, best not to fully quote long posts (ref post #11 ) as it makes the thread harder to read/navigate and just occupies storage space needlessly. If you want to quote, quote small, relevant parts only.

 

[kashif.special2005]

Hi Kashif,

I'm not sure of worksheet defintions. Please refer below.

Sheet 4 - is criteria to delete the data
Sheet 2 - where data we want to delete

Biz

Hi Biz,

Yes you are right in sheet4 I puted criteria values in a column, and sheet2 where the actual data exists.

Thanks
Kashif

 

[Biz]

Hi Peter & Kashif,

Thank you both for your help.

Kind Regards

Biz