Do you see the dotted lines that you get after you do a print or print preview?
If you do
Tools|Options|view tab|uncheck display page breaks
does the run time go back to normal?
You may want to do something like:
Option Explicit
Sub testme()
Dim CalcMode As Long
Dim ViewMode As Long
Application.ScreenUpdating = False
CalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'do the work (Your code goes here)
'put things back to what they were
Application.Calculation = CalcMode
ActiveWindow.View = ViewMode
End Sub
Being in View|PageBreak Preview mode can slow macros down, too.
=========
If you run these procedures on their own, you may want to put that stuff in each
procedure--and remove it from the giant (do all of them at once).
==========================
Looping through the rows and deleting them can be very slow.
You could change the code to create a range of cells that should be deleted,
then delete that range at the end.
=======
Option Explicit
Sub DeleteRows2A()
Dim CalcMode As Long
Dim ViewMode As Long
Dim myList As Variant
Dim myListAsStr As String
Dim res As Variant 'could be an error
Dim LastRow As Long
Dim rw As Long
Dim DeptCode As String
myList = Array("PCPA", "PCPB", "OFIA", "OFIB", "FHI")
'Join was added in xl2k.
'It won't work in earlier versions -- or on Mac's.
myListAsStr = Join(myList, ", ")
DeptCode = InputBox(Prompt:="Please type in your department code" _
& " (only one):" & vbLf & myListAsStr, _
Title:="Department Filter")
If Trim(DeptCode) = "" Then
'user hit cancel
Exit Sub
End If
res = Application.Match(DeptCode, myList, 0)
If IsError(res) Then
MsgBox "Please select from the list!"
Exit Sub
End If
Application.ScreenUpdating = False
CalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
With ActiveSheet 'I like to qualify my ranges
LastRow = .Cells(.Rows.Count, "f").End(xlUp).Row
For rw = LastRow To 2 Step -1
If LCase(.Cells(rw, "f").Value) <> LCase(DeptCode) Then
.Rows(rw).Delete
End If
Next rw
End With
'put things back to what they were
Application.Calculation = CalcMode
ActiveWindow.View = ViewMode
End Sub
============
This version builds the range and deletes it at the end. Excel does have a bug
that if this range has more than 8192 discontinuous areas, it'll break -- with
no notice. So you'll want to know your data before settling on this one:
Option Explicit
Sub DeleteRows2B()
Dim CalcMode As Long
Dim ViewMode As Long
Dim myList As Variant
Dim myListAsStr As String
Dim res As Variant 'could be an error
Dim LastRow As Long
Dim rw As Long
Dim DeptCode As String
Dim DelRng As Range
myList = Array("PCPA", "PCPB", "OFIA", "OFIB", "FHI")
'Join was added in xl2k.
'It won't work in earlier versions -- or on Mac's.
myListAsStr = Join(myList, ", ")
DeptCode = InputBox(Prompt:="Please type in your department code" _
& " (only one):" & vbLf & myListAsStr, _
Title:="Department Filter")
If Trim(DeptCode) = "" Then
'user hit cancel
Exit Sub
End If
res = Application.Match(DeptCode, myList, 0)
If IsError(res) Then
MsgBox "Please select from the list!"
Exit Sub
End If
Application.ScreenUpdating = False
CalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
With ActiveSheet 'I like to qualify my ranges
LastRow = .Cells(.Rows.Count, "f").End(xlUp).Row
For rw = LastRow To 2 Step -1
If LCase(.Cells(rw, "f").Value) <> LCase(DeptCode) Then
If DelRng Is Nothing Then
Set DelRng = .Cells(rw, "A")
Else
Set DelRng = Union(.Cells(rw, "A"), DelRng)
End If
End If
Next rw
End With
'do the delete in one step
If DelRng Is Nothing Then
'do nothing
Else
DelRng.EntireRow.Delete
End If
'put things back to what they were
Application.Calculation = CalcMode
ActiveWindow.View = ViewMode
End Sub
