Как быстро удалять лишние строки?

 Rows(i).Delete

==============================================================
Мне необходимо удалить строки со нулевыми значиниями из Листа, но там порядка 200 000 строк.
ZVI 
Процедура очистки(удаления) строк в столбце ColNum со значениями DelValue: 
'===================================================================================
' Sub         : DelRows(TableHeader,ColNum,DelValue)
' TableHeader : Range; table header range
' ColNum      : Long; column number with DelValue
' DelValue    : Variant; value of rows to be deleted
'-------------+---------------------------------------------------------------------
' VBA call    : DelRows ActiveSheet.Range("A1:H1"), 5, 0
'-------------+---------------------------------------------------------------------
' Created     : ZVI:2009:12:26 [url]http://www.sql.ru/forum/actualthread.aspx?tid=722758[/url]
'-----------------------------------------------------------------------------------
Sub DelRows(TableHeader As Range, ColNum As Long, DelValue)
  Dim Arr(), r&, rs&, cs&, i&, v, ac
  With TableHeader.CurrentRegion
    rs = .Rows.Count - TableHeader.Row + .Row
    cs = .Columns.Count - TableHeader.Column + .Column
  End With
  With TableHeader.Resize(rs, 1)
    Arr() = .Offset(, cs).Value
    ' Check DelValue
    For Each v In .Offset(, ColNum - 1).Value
      r = r + 1
      If v <> DelValue Then
        i = i + 1
        Arr(r, 1) = 1
      End If
    Next
    If i < rs Then
      ' Freeze on
      With Application
        .ScreenUpdating = False
        .EnableEvents = False
        ac = .Calculation: .Calculation = xlCalculationManual
      End With
      ' Delete rows with DelValue in ColNum
      .Offset(, cs) = Arr
      .Resize(, cs + 1).Sort .Cells(1).Offset(, cs), 1, Header:=xlNo
      .Resize(, 1).Offset(, cs).ClearContents
      .Resize(rs - i, cs).Offset(i).Clear   ' или .Resize(rs - i).Offset(i).EntireRow.Delete
      ' Freeze off
      With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = ac
      End With
    End If
  End With
End Sub
 
 
Тестирование:
 
Sub Test()
  DelRows ActiveSheet.Range("A1:H1"), 5, 0
End Sub
 
Круто, попробовал на миллионе строк в Excel 2007, работает, причем очень быстро.
==

Sub ВыделитьСтроки() 'выделить/удалить все НЕ пустые строки не содержащие значение "Баранова О.В."
Dim строка As LongPtr
Dim строки As Range
Dim строки2 As Range
 
     For строка = 3000 To 1 Step -1
        If Cells(строка, 1) <> "Баранова О.В." And Cells(строка, 1) <> "" Then Set строки = Rows(строка)
            If строки2 Is Nothing Then Set строки2 = строки Else Set строки2 = Union(строки2, строки)
     Next строка
  
'Debug.Print строки2.Address 'посмотреть диапазоны адресов
If Not строки2 Is Nothing Then строки2.Select 'выделить
'If Not строки2 Is Nothing Then строки2.Delete Shift:=xlUp 'удалить со свигом вверх
End Sub

Sub ВыделитьСтроки() 'выделить/удалить все НЕ пустые строки не содержащие значение "Баранова О.В."
Dim строка As Long, строки As Range, строки2 As Range, R
R = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Value 'забрать в массив столбец А с первой ячейки до последней заполнненной
     For строка = 1 To UBound(R) 'по последний заполненный
        If R(строка, 1) <> "" And R(строка, 1) <> "Баранова О.В." Then Set строки = Rows(строка)
            If строки2 Is Nothing Then Set строки2 = строки Else Set строки2 = Union(строки2, строки)
     Next строка
If Not строки2 Is Nothing Then строки2.Select 'выделить
'If Not строки2 Is Nothing Then строки2.Delete Shift:=xlUp 'удалить со свигом вверх
End Sub

If R(строка, 1) <> "" And R(строка, 1) <> "Баранова О.В." Then

With Application
.ScreenUpdating = False
 .Calculation = xlManual
 End With

mass = Range(Cells(1, 1), Cells(row_, col_)).Value

idcolprb = 19 ' перед работой этого кода в 19 колонке делаю пометки дубликатов
 
' ST - проверяемая в данную итерацию строка
' ST2 - собираемый на удаление диапазон срок
 
 Dim ST As Range, ST2 As Range
 i = 2
    Do
        If Cells(i, idcolprb).Value = Empty Then Exit Do
        If Cells(i, idcolprb).Value = "дубликат" Then
            Set ST = Rows(i)
            If ST2 Is Nothing Then Set ST2 = ST Else Set ST2 = Union(ST2, ST)
        End If
        i = i + 1
     Loop
If Not ST2 Is Nothing Then 
    ST2.Select 'ВЫДЕЛИТЬ все отобранные строки
    ST2.Delete Shift:=xlUp 'удалить выделенные строки со сдвигом вверх
end if

Dim ws As Worksheet
Dim j1 As Long, j2 As Long, j3, dt
 
 
With Application
.ScreenUpdating = False
 .Calculation = xlManual
 End With
Set ws = Excel.Worksheets("zrab")
'' заполнение 150000 строк, 150 столбцов
'ws.Range("b2:ee150000") = "wwwwjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj"
dt = Timer
j1 = 150000
j2 = 0
j3 = 0
Do While j1 > 0
j2 = j2 + 1
j3 = j3 + 1
 
If j2 = 5 Then  '''каждую 5-ю
ws.Rows(j1).Delete
j2 = 0
If j3 > 1000 Then   '''''трассер
Debug.Print j1; (Timer - dt) \ 1
j3 = 0
End If
 
 
 
End If
j1 = j1 - 1
Loop
Debug.Print Now
MsgBox "выполнение в секундах(около 4мин)=" & (Timer - dt) \ 1

ST2.EntireRow.Delete