Optimize Excel VBA Code - excel

Question

I have the following VBA code within excel. It's goal is to remove a row if the given text is found, as well as remove the row directly below it. It needs to scan roughly 700k rows and is taking roughly an hour to do 100k rows. Does anyone see any optimization?
Sub RemovePageHeaders()
Application.ScreenUpdating = False
Dim objRange As Range
Set objRange = Cells.Find("HeaderText")
While objRange <> ""
objRange.Offset(1, 0).Rows(1).EntireRow.Delete
objRange.Rows(1).EntireRow.Delete
Set objRange = Cells.Find("HeaderText")
Wend
MsgBox ("I'm done removing page headers!")
End Sub
Thanks in advance!

Answer 1

Try the following sub. It loops from the bottomm-most row to the top, checking column 3 for "HeaderText". If that's found, it delete the row and the one below it. On a C2D E8500 with 2 gigs of RAM it takes just over a minute per 100,000 rows on a sheet with 1 million rows.
Sub RemoveHeaders()
Dim i As Long
Application.ScreenUpdating = False
Debug.Print "Started: " & Now
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If ActiveSheet.Cells(i, 3) = "HeaderText" Then
ActiveSheet.Range(i & ":" & i + 1).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
Debug.Print "Finished: " & Now
End Sub
EDIT
For a slightly ghetto but possibly much faster solution try this:
Change the constant in the below code to the number of the first column that's blank in every row. For example if your data takes up columns A-F, you want the constant to be 7 (column G).
Run the code, it will put the row number next to every entry. Should take around 30 seconds.
Sort the ENTIRE data by column C; this should take less than a minute.
Find "HeaderText" visually, select and delete all the rows.
Sort by your row-numbered column ("G" in my example).
Delete the row-numbered column (again, "G" in my example).
Sub NumberColumns()
Const BLANK_COLUMN = 7
Dim i As Long
For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
ActiveSheet.Cells(i, BLANK_COLUMN) = i
Next i
Debug.Print "done"
End Sub

Answer 2

Even if it doesn't fully answer the question, it may help any reader so...
There are several tips on the web about optimizing vba. In particular, you can do:
'turn off some Excel functionality so your code runs faster
'these two are especially very efficient
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'use these if you really need to
Application.DisplayStatusBar = False
Application.EnableEvents = False 'is very efficient if you have ANY event associated with what your macro is going to do
'code goes here
'at the end, don't forget to restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
See here for more information

Answer 3

Putting this entry in a little late. It should be about 2X faster than the accepted solution. I used my XP Excel 2003 computer with 1 gig to figure it out.
Sub DeleteHeaderText()
Dim bUnion As Boolean
Dim d1 As Double
Dim l As Long
Dim rDelete As Range
Dim wks As Worksheet
Dim vData As Variant
d1 = Timer
Application.EnableEvents = False
Application.ScreenUpdating = False
bUnion = False
Set wks = ActiveSheet
lEnd = ActiveSheet.UsedRange.Rows.Count
vData = wks.Range("C1:C" & lEnd).Value2
For l = 1 To lEnd
If vData(l, 1) = "HeaderText" Then
If bUnion Then
Set rDelete = Union(rDelete, wks.Range("A" & l, "A" & l + 1))
Else
Set rDelete = wks.Range("A" & l, "A" & l + 1)
bUnion = True
End If
l = l + 1
End If
Next l
Debug.Print Timer() - d1
rDelete.EntireRow.Delete
Debug.Print Timer() - d1
End Sub

Answer 4

I know this is late, but if I understand your problem, then you are deleting rows based on a "HeaderText" in column C. So, since i didn't look at your data, i created my own. I created 700,000 rows and every 9th row contained the "HeaderText" string. It deleted ~233k rows ("HeaderText" row + row before + row after) and ran in 2.2 seconds on my computer. Give it a try!!
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Sub DeleteHeaders()
Dim LastRow As Long
Dim I As Long
Dim WkSheet As Excel.Worksheet
Dim VArray As Variant
Dim NewArray() As String
Dim BooleanArray() As Boolean
Dim NewArrayCount As Long
Dim J As Long
Dim T As Double
Dim DeleteRowCount As Long
T = timeGetTime
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Set WkSheet = ThisWorkbook.Sheets("Sheet1")
With WkSheet.UsedRange
LastRow = .Rows.Count
VArray = .Value
End With
ReDim BooleanArray(0 To UBound(VArray, 1) - 1), NewArray(UBound(VArray, 1) - 1, 0 To UBound(VArray, 2))
For I = 1 To UBound(VArray, 1)
If InStrB(1, VArray(I, 3), "HeaderText", vbBinaryCompare) <> 0 Then
BooleanArray(I - 1) = Not BooleanArray(I - 1)
BooleanArray(I) = Not BooleanArray(I)
BooleanArray(I + 1) = Not BooleanArray(I + 1)
End If
Next I
For I = LBound(BooleanArray, 1) To UBound(BooleanArray, 1)
If BooleanArray(I) = False Then
For J = LBound(VArray, 2) To UBound(VArray, 2)
NewArray(NewArrayCount, J - 1) = VArray(I + 1, J)
Next J
NewArrayCount = NewArrayCount + 1
Else
DeleteRowCount = DeleteRowCount + 1
End If
Next I
With WkSheet
.Cells.Delete
.Range("a1:c" & NewArrayCount).Value = NewArray
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Erase NewArray, BooleanArray, VArray
MsgBox "Deleted " & DeleteRowCount & " rows." & vbNewLine & vbNewLine & _
"Run time: " & Round((timeGetTime - T) / 1000, 3) & " seconds.", vbOKOnly, "RunTime"
End Sub

Answer 5

Here's a solution that will run on 100k rows in about 5-20 seconds depending on how many occurances of 'HeaderText' you have. As you requested, it will delete both the row with HeaderText in the C column as well as the row directly above it.
Update:
As it's been pointed out, this works on smaller data sets up to about 100k, but on larger sets it's really doesn't. Back to the drawing board :)
Sub DeleteHeaders()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim varray As Variant
lastRow = Range("C" & Rows.Count).End(xlUp).Row
On Error Resume Next
varray = Range("C1:C" & lastRow).Value
For i = UBound(varray, 1) To 1 Step -1
If varray(i, 1) = "HeaderText" Then
Range("C" & i - 1, Range("C" & i)).EntireRow.Delete
i = i - 1
End If
Next
Application.ScreenUpdating = True
End Sub
How it works:
By dumping the entire C column into a variant array and working from it within excel, you get major speed increase. The varray is laid out like (1, 1), (2, 1), (3, 1) with the first number being the row number, so all you have to do is loop through it backwards. The key is making sure to delete both rows at the same time and decrementing i by one more.

Answer 6

The following is code lifted from a Bill Jelen book that is fantastic for this purpose.
Use a column (column A for my code) with some logic to determine if a row should be hidden on not.
Use the following formula in all applicable cells in that column
=IF(test TRUE to hide, 1, "keep")
Now use the VBA below
Range("A1:A10000").SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow.Delete
This selects all rows with a number returned by the formula at once, which is exactly the rows you want to delete. No looping required!

Answer 7

Here on my blog have a scripts for this:
Sample One:
Sub DelBlankRows()
Range("D1:D" & Cells _
(Rows.Count,2).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sample two:
Sub DeleteRowsWithSpecifiedData()
'Looks in Column D and requires Column IV to be clean
Columns(4).EntireColumn.Insert
With Range("D1:D" & ActiveSheet.UsedRange.Rows.Count)
.FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=""Not Needed"",NA()))"
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
End With
On Error GoTo 0
Columns(4).EntireColumn.Delete
End Sub