VBA to delete entire row based on cell value - vba

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