Hiding Blocks of Pivot Table Rows w/VB. I bit of help PLZ

[Jeff9915]

I wrote and borrowed some of this code, thanks to you all here. I wanted to speed up hiding rows in a simple Pivot table that is only dependent on the Total column value. 1 line/item This code worked in a regular worksheet but I'm not allowed to hide mutiple rows that are not together. ie i cannot hide rows 1:3, 7:10 leaving only rows 4,5,6 visible. It would really speed things up if i can hide multiple blocks of data. Or even blocks of data for that matter. I get " You cannot hide this selection" as the error with this code. What would be the best work around. Thanks All!!!

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

 

[Jeff9915]

ok Since i haven't gotten a response either way i wrote code that works for my sheet that will hide the rows i don't want based on the total field and i'll share it with you all in case any finds it helpfull. It is SUBSTANTIALLY FASTER than deleting 1 row at a time. THANKS!!

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
    Dim d As Long
    Dim rnew 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
    
     val1 = Range("K42") 'sets range for val1
     DeletedRows = 0
     d = 0
     rnew = 6
    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 + 2
            Set MyCell = ws.Cells(r, "a")
            If MyDeleteRange Is Nothing Then
               '- first matching cell
               Set MyDeleteRange = MyCell
            End If
        End If
           
            If DeletedRows <> 0 Then d = d + 2 'keeps counter in sync
            If DeletedRows = 0 Then rnew = rnew + 2 'keeps counter in sync
            
        If DeletedRows <> d Then
        If Not MyDeleteRange Is Nothing Then
            Set MyDeleteRange = Range(MyDeleteRange, MyCell)
            MyDeleteRange.delete
        End If
      ' these below reset variables for zero and correct starting/ending row
      LastRow = LastRow - DeletedRows
      r = rnew
      DeletedRows = 0
      d = 0
      Set MyCell = ws.Cells(r, "a")
      Set MyDeleteRange = Nothing
     
     End If
    r = r + 1
    Next
    '----------------------------------------------------------------
       
    Application.Calculation = xlCalculationAutomatic
            
    
End Sub