VBA to delete entire row based on cell value

Question

I'm experiencing some issues getting the provided VBA code working and would appreciate any assistance.

I have two Workbooks (1) is a monthly report I receive that has multiple worksheets, Worksheet " host_scan_data " contains the source of the information I will need to work with. The other Workbook (2) is where I will store all consolidated date month over month.

How I'm trying to accomplish this task: 1. launch workbook #2 2. click a button that has the following VBA code assigned to (see below) 3. browse and select my monthly report (workbook #1) 4. specify the worksheet tab in workbook #2 where i'd like to store this consolidate information 5. prompt user to validate worksheet tab where data will be stored

Based on the responses above the macro will then analyze Column K within the " host_scan_data " Sheet of the Workbook (1), and I would like for it to remove all rows where Column k contains a "0" (note the only values i'm concerned about are 4,3,2,1). Once that action is complete i'd like for the macro to copy the consolidated list of entry's over to the location specified in step #4 above.

I've tried this with a few variations of code and other solutions appear to work fine when the " host_scan_data " Sheet contains <4,000 rows however once I exceed that number (give or take) excel becomes unresponsive. Ideally this solution will need to handle approx 150,000+ rows.

Here is the code i'm currently using, when i execute it errors out at ".Sort .Columns(cl + 1), Header:=xlYes":

The Code I Have so far:

Sub Import()
 Dim strAnswer
 Dim itAnswer As String
 Dim OpenFileName As String
 Dim wb As Workbook
 Dim db As Workbook
 Dim Avals As Variant, X As Variant
 Dim i As Long, LR As Long

 'Optimize Code
  Call OptimizeCode_Begin

 'Select and Open workbook
 OpenFileName = Application.GetOpenFilename("*.xlsx,")
 If OpenFileName = "False" Then Exit Sub
 Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
 Set db = ThisWorkbook

 'Provide Sheet Input
    strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")

    If strAnswer = "" Then

        MsgBox "You must enter a valid name. Exiting now..."
        wb.Close
        Exit Sub
    Else

        Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
        If Response = vbNo Then
            MsgBox "Got it, you made a mistake. Exiting now..."
            wb.Close
            Exit Sub
        Else: MsgBox "Importing Now!"
        End If
    End If

    wb.Sheets("host_scan_data").Activate
            Dim rs, cl, Q()
            Dim arr1, j, C, s As Long

            Dim t As String: t = "4"
            Dim u As String: u = "3"
            Dim v As String: v = "2"
            Dim w As String: w = "1"

            If Cells(1) = "" Then Cells(1) = Chr(2)
            'Application.Calculation = xlManual
            rs = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByRows, xlPrevious).Row
            cl = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByColumns, xlPrevious).Column
            ReDim Q(1 To rs, 1 To 1)
            arr1 = wb.Sheets("host_scan_data").Cells(1, "k").Resize(rs)
            For j = 1 To rs
                C = arr1(j, 1)
                If (C <> t) * (C <> u) * (C <> v) * (C <> w) Then Q(j, 1) = 1: s = s + 1
            Next j
            If s > 0 Then
                With Cells(1).Resize(rs, cl + 1)
                    .Columns(cl + 1) = Q
                    .Sort .Columns(cl + 1), Header:=xlYes
                    .Cells(cl + 1).Resize(s).EntireRow.Delete
                End With
            End If

            countNum = (Application.CountA(Range("B:B"))) - 1
            MsgBox (countNum & " Rows being imported now!")
            countNum = countNum + 2
            db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
            db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
            db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
            db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
            db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
            db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
            db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
            db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
            MsgBox ("Done")
            'Close nessus file
            wb.Close SaveChanges:=False
        'Else
            'MsgBox "You must enter 1 or 2 only. Exiting now..."
            'wb.Close
            'Exit Sub
   'End If



 Sheets(strAnswer).Select

 'Optimize Code
  Call OptimizeCode_End

End Sub

Answer 1

So here is what may be happening.

If the row you are deleting has data used, in a formula somewhere else, that formula is going to recalculate on every iteration of the row delete.

I had this problem with a data set which has many Vlookup functions pulling data.

here is what I did and it take a few seconds rather than 30min

 Sub removeLines() Dim i As Long Dim celltxt As String Dim EOF As Boolean Dim rangesize As Long EOF = False i = 1 'My data has "End of File" at the end so I check for that ' Though it would be better to used usedRange While Not (EOF) celltxt = ActiveSheet.Cells(i, 1).Text If InStr(1, celltxt, "end", VbCompareMethod.vbTextCompare) > 0 Then EOF = True 'if we reach the "end Of file" then exit ' so I clear a cell that has no influence on any functions thus ' it executes quickly ElseIf InStr(1, celltxt, "J") <> 1 Then Cells(i, 1).Clear End If i = i + 1 Wend ' once all the rows to be deleted are marked with the cleared cell ' I use the specialCells to select and delete all the rows at once ' so that the dependent formula are only recalculated once Columns("A:A").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Delete End Sub 

hope this helps and that it is read able

Answer 2

I tried a little different approach by using AutoFilter and i'm seeing a high success rate on my larger lists however there still is one issue. With the code below i was able to parse through 67k+ rows and filter/delete any row contains a "0" in my column K (this takes approx 276 seconds to complete), after the code filters and deletes the rows with zeros it clears any existing filters then is to copy the remaining data into my Workbook #2 (this is approx 7k rows) however it is consistently only copying 17 rows of data into my workbook #2, it just seems to stops and i have no idea why. Also, while 4.5 mins to complete the consolidation could be acceptable does anyone have any ideas on how to speed this up?

Sub Import()
 Dim strAnswer
 Dim itAnswer As String
 Dim OpenFileName As String
 Dim wb As Workbook
 Dim db As Workbook
 Dim Avals As Variant, X As Variant
 Dim i As Long
 Dim FileLastRow As Long
 Dim t As Single
 Dim SevRng As Range
 t = Timer

 'Optimize Code
  Call OptimizeCode_Begin

 'Select and Open workbook
 OpenFileName = Application.GetOpenFilename("*.xlsx,")
 If OpenFileName = "False" Then Exit Sub
 Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
 Set db = ThisWorkbook

 'Provide Sheet Input
    strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")

    If strAnswer = "" Then

        MsgBox "You must enter a valid name. Exiting now..."
        wb.Close
        Exit Sub
    Else

        Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
        If Response = vbNo Then
            MsgBox "Got it, you made a mistake. Exiting now..."
            wb.Close
            Exit Sub
        Else: MsgBox "Importing Now!"
        End If
    End If

    FileLastRow = wb.Sheets("host_scan_data").Range("K" & Rows.Count).End(xlUp).Row
    Set SevRng = wb.Sheets("host_scan_data").Range("K2:K" & FileLastRow)

    Application.DisplayAlerts = False
    With SevRng
        .AutoFilter Field:=11, Criteria1:="0"
        .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Delete
        .Cells.AutoFilter
    End With

    Application.DisplayAlerts = True

    MsgBox "Consolidated in " & Timer - t & " seconds."

            countNum = (Application.CountA(Range("B:B"))) - 1
            MsgBox (countNum & " Rows being imported now!")
            countNum = countNum + 2
            db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
            db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
            db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
            db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
            db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
            db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
            db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
            db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
            MsgBox ("Done")
            'Close nessus file
            wb.Close SaveChanges:=False

 Sheets(strAnswer).Select

 'Optimize Code
  Call OptimizeCode_End

End Sub

Answer 3

Does your "MsgBox (countNum & " Rows being imported now!")" return the correct number of rows? CountA will stop counting at the first empty cell.

Try instread: countNum = ActiveSheet.UsedRange.Rows.Count