Code:

```
Sub ptrows()
Dim tval
Dim val1
Dim pmon As String
Dim MyDeleteRange As Range ' sets range for deletion
'Dim DeletedRows As Long
Dim MyCell As Range ' single cell added to MyDeleteRange
Dim LastRow As Long
Dim ws As Worksheet
Dim Foundcell As Object
Dim r As Long
Sheet8.Activate
Range("D2").Select
pmon = ActiveCell
Sheet8.Activate
ActiveSheet.PivotTables("PivotTable1").RefreshTable
Range("A5").Select
Selection.ShowDetail = False
Range("a6").Activate
ActiveSheet.PivotTables("PivotTable1").PivotFields("Month").CurrentPage = pmon 'Sets Pivot Month
ActiveSheet.PivotTables("PivotTable1").PivotFields("Year").CurrentPage = _
"(All)" 'sets fields to all
'tval = ActiveCell.Offset(0, 8)
val1 = Range("K42") 'sets range for val1
Set ws = ActiveSheet
'- find last row
Set Foundcell = ActiveSheet.Cells.Find(what:="*", _
after:=Range("I65536"), searchdirection:=xlPrevious)
LastRow = Foundcell.Row
'----------------------------------------------------------------
'- check cells
For r = 6 To LastRow
If Not (ws.Cells(r, "i") > val1) And Not (ws.Cells(r, "i") < -val1) Then
DeletedRows = DeletedRows + 1
Set MyCell = ws.Cells(r, "i")
If MyDeleteRange Is Nothing Then
'- first matching cell
Set MyDeleteRange = MyCell
Else
'- add subsequent matching cells to the range
Set MyDeleteRange = Union(MyDeleteRange, MyCell)
End If
End If
'- Hide Data in the range
Next
'----------------------------------------------------------------
If Not MyDeleteRange Is Nothing Then
MyDeleteRange.delete
End If
Application.Calculation = xlCalculationAutomatic
End Sub
```