ExcelBanter - View Single Post

okrob

Need some help condensing this code...

I used some of that good old copy and paste from this group to make
these, but I wondered if I could condense them into one loop so that
I'm not looping the entire column 3 times. It gets large and takes a
long time.
I call the subs from another routine and afterward I turn on the screen
updating.
Basically the code searches the column from the bottom to the top
looking for 3 different things and when it finds it, it deletes the
entire row.

Code:

Sub killRow1()
Application.ScreenUpdating = False
On Error Resume Next
Dim rRow()
nrows = ActiveSheet.UsedRange.Rows.Count
ReDim rRow(nrows)
Application.Calculation = xlCalculationManual
With ActiveSheet.Range("A1:A" & nrows)
    Set C = .Find(What:="8=FWD", LookIn:=xlFormulas, Lookat:=xlPart)
    If Not C Is Nothing Then
        firstAddress = C.Address
        Do
            Number = Number + 1
            rRow(Number) = C.Row
            Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address < firstAddress
    End If
End With
For i = Number To 1 Step -1
    Range("A" & rRow(i)).EntireRow.Delete
Next i
'MsgBox "8=FWD done"
Application.Calculation = xlCalculationAutomatic
End Sub

Sub killRow2()
Application.ScreenUpdating = False
On Error Resume Next
Dim rRow()
nrows = ActiveSheet.UsedRange.Rows.Count
ReDim rRow(nrows)
Application.Calculation = xlCalculationManual
With ActiveSheet.Range("A1:A" & nrows)
    Set C = .Find(What:="PF KEY", LookIn:=xlFormulas, Lookat:=xlPart)
    If Not C Is Nothing Then
        firstAddress = C.Address
        Do
            Number = Number + 1
            rRow(Number) = C.Row
            Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address < firstAddress
    End If
End With
For i = Number To 1 Step -1
    Range("A" & rRow(i)).EntireRow.Delete
Next i
'MsgBox "PF KEY done"
Application.Calculation = xlCalculationAutomatic
End Sub

Sub killRow3()
Application.ScreenUpdating = False
On Error Resume Next
Dim rRow()
nrows = ActiveSheet.UsedRange.Rows.Count
ReDim rRow(nrows)
Application.Calculation = xlCalculationManual
With ActiveSheet.Range("A1:A" & nrows)
    Set C = .Find(What:="END OF DATA", LookIn:=xlFormulas,
Lookat:=xlPart)
    If Not C Is Nothing Then
        firstAddress = C.Address
        Do
            Number = Number + 1
            rRow(Number) = C.Row
            Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address < firstAddress
    End If
End With
For i = Number To 1 Step -1
    Range("A" & rRow(i)).EntireRow.Delete
Next i
'MsgBox "END OF DATA done"
Application.Calculation = xlCalculationAutomatic
End Sub

Thanks in advance,
Rob