Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 325
  • Last Modified:

Space and grouping after pivot table

I am currently running the attached code to put space after a pivot table.  The process works as follows I first remove all groupings and then I add space below the pivot table if there is data below it and then add a grouping back and set it to level one.  

What I would like to change is that it will check and see if there is 20 blank rows below the pivot and if not make it 20 blank rows and then group the data back showing level 1

Thanks
montrof

Sub PivotExpander()
    Dim WS As Worksheet
    Dim pt As PivotTable
    Dim rNext As Range
    
     RGroup
    
    For Each WS In ActiveWorkbook.Worksheets
    If WS.Name <> "test" Then
        
        WS.Select
            
        For Each pt In WS.PivotTables
        
                    With pt.TableRange1
                    If Application.CountA(.Offset(.Rows.Count).Resize(10)) Then
                    .Offset(.Rows.Count).Resize(20).EntireRow.Insert
                    With pt.TableRange1
                        .Offset(-1).Resize(.Rows.Count + 21).EntireRow.Group
                        
                                                            
                    End With
                End If
            End With
        Next pt
       
    ActiveSheet.Outline.ShowLevels RowLevels:=1
    End If
    Next WS
    
  
End Sub
Sub RGroup()

Dim WS As Worksheet
 On Error Resume Next
For Each WS In ActiveWorkbook.Worksheets
 If WS.Name <> "test" Then
    WS.Select
    Cells.Select
    Selection.Rows.UnGroup
    Selection.Rows.Hidden = False
    Range("A1").Select
 End If
Next WS

End Sub

Open in new window

0
montrof
Asked:
montrof
  • 7
  • 5
1 Solution
 
andrewssd3Commented:
This code is generalised to add a number of rows you specify after a range you specify.  It uses find to look for any data in any column under your range.  Give it a try:
Public Sub Test()

    Call AddNBlankRowsAfterRange(20, ActiveSheet.Range("A1:B109"))

End Sub

Public Sub AddNBlankRowsAfterRange(ByVal lNumRowsToAdd As Long, ByRef rngAfter As Range)

    Dim rngRowAfter As Range
    Dim rngNextNonBlank As Range
    Dim lNumBlankRows As Long
    
    ' get the first cell of the row after the range passed in
    Set rngRowAfter = rngAfter.Offset(rngAfter.Rows.Count, 0).EntireRow.Cells(1, 1)
    
    ' now find the next non-blank cell
    Set rngNextNonBlank = rngAfter.Worksheet.Cells.Find(What:="*", After:=rngRowAfter, SearchOrder:=xlByRows)
    
    lNumBlankRows = rngNextNonBlank.Row - rngRowAfter.Row
    
    ' if search wrapped round then there was no data below our range, so nothing to do
    If lNumBlankRows < 0 Then
        Exit Sub
    End If
    
    If lNumBlankRows < lNumRowsToAdd Then
        rngNextNonBlank.Resize(lNumRowsToAdd - lNumBlankRows, 1).EntireRow.Insert
    End If

End Sub

Open in new window

0
 
andrewssd3Commented:
You could be paranoid and add this at the top to ensure there are enough rows available on the sheet and avoid run-time errors
    If (rngAfter.Row + rngAfter.Rows.Count + lNumRowsToAdd - 1) > rngAfter.Worksheet.Rows.Count Then
        MsgBox "Not enough space on sheet to add " & CStr(lNumRowsToAdd) & " rows"
        Exit Sub
    End If
    

Open in new window

Could happen if you have lots of data or start to want adding 1,000,000 blank rows...
0
 
montrofAuthor Commented:
This is on the right track except if there the range allready has 20 blank cells or has more than 20 then I want it to delete the excess blank rows.  So it would add the rows if it was less than 20 and delete if it was more.  Here is how I am referencing it

Public Sub Test()
 Dim pvtT As PivotTable
    Dim ws As Worksheet
    Dim pt As PivotTable
    Dim lastcell As String
    Set rng = Selection
    Dim pivotlast As String
    Dim pivotlast2 As String
    Dim vRange As range
    


    For Each ws In ActiveWorkbook.Worksheets
        ws.Select
        For Each pt In ws.PivotTables

            With pt.TableRange1

                lastcell = .Rows(.Rows.Count).Row
                
            End With
            pivotlast = Cells(lastcell + 1, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
            pivotlast2 = ws.range(pivotlast).End(xlDown).Offset(-2).Address(RowAbsolute:=False, ColumnAbsolute:=False)
            rowlast1 = ws.range(pivotlast).End(xlDown).Offset(-2).Row
            
             


    Call AddNBlankRowsAfterRange(20, ws.range(pivotlast, pivotlast2))
Next pt
    Next ws
End Sub

Open in new window

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
montrofAuthor Commented:
I also want to group the new range.  Sorry I forgot to say that.
0
 
andrewssd3Commented:
Is this what you mean?
Public Sub AddNBlankRowsAfterRange(ByVal lNumRowsToAdd As Long, ByRef rngAfter As Range)

    Dim rngRowAfter As Range
    Dim rngNextNonBlank As Range
    Dim lNumBlankRows As Long
    
    If (rngAfter.Row + rngAfter.Rows.Count + lNumRowsToAdd - 1) > rngAfter.Worksheet.Rows.Count Then
        MsgBox "Not enough space on sheet to add " & CStr(lNumRowsToAdd) & " rows"
        Exit Sub
    End If
    
    ' get the first cell of the row after the range passed in
    Set rngRowAfter = rngAfter.Offset(rngAfter.Rows.Count, 0).EntireRow.Cells(1, 1)
    
    ' now find the next non-blank cell
    Set rngNextNonBlank = rngAfter.Worksheet.Cells.Find(What:="*", After:=rngRowAfter, SearchOrder:=xlByRows)
    
    lNumBlankRows = rngNextNonBlank.Row - rngRowAfter.Row
    
    ' if search wrapped round then there was no data below our range, so nothing to do
    Select Case lNumBlankRows
        Case Is > lNumRowsToAdd
            rngRowAfter.Resize(lNumBlankRows - lNumRowsToAdd, 1).EntireRow.Delete
        Case Is = lNumRowsToAdd
            ' nothing to do
        Case Is >= 0
            rngNextNonBlank.Resize(lNumRowsToAdd - lNumBlankRows, 1).EntireRow.Insert
    End Select
    
    Set rngRowAfter = rngAfter.Offset(rngAfter.Rows.Count, 0).Resize(lNumRowsToAdd, 1).EntireRow
    rngRowAfter.Group
    rngRowAfter.EntireRow.Hidden = True

End Sub

Open in new window

0
 
montrofAuthor Commented:
That is very close except for I need it to include the pivot table in the range it is grouping
0
 
andrewssd3Commented:
OK - I would probably change the sub to a function that returns the blank rows it has added as a range, then you can do what you want with it:
Public Function AddNBlankRowsAfterRange(ByVal lNumRowsToAdd As Long, ByRef rngAfter As Range) As Range

    Dim rngRowAfter As Range
    Dim rngNextNonBlank As Range
    Dim lNumBlankRows As Long
    
    If (rngAfter.Row + rngAfter.Rows.Count + lNumRowsToAdd - 1) > rngAfter.Worksheet.Rows.Count Then
        MsgBox "Not enough space on sheet to add " & CStr(lNumRowsToAdd) & " rows"
        Exit Function
    End If
    
    ' get the first cell of the row after the range passed in
    Set rngRowAfter = rngAfter.Offset(rngAfter.Rows.Count, 0).EntireRow.Cells(1, 1)
    
    ' now find the next non-blank cell
    Set rngNextNonBlank = rngAfter.Worksheet.Cells.Find(What:="*", After:=rngRowAfter, SearchOrder:=xlByRows)
    
    lNumBlankRows = rngNextNonBlank.Row - rngRowAfter.Row
    
    ' if search wrapped round then there was no data below our range, so nothing to do
    Select Case lNumBlankRows
        Case Is > lNumRowsToAdd
            rngRowAfter.Resize(lNumBlankRows - lNumRowsToAdd, 1).EntireRow.Delete
        Case Is = lNumRowsToAdd
            ' nothing to do
        Case Is >= 0
            rngNextNonBlank.Resize(lNumRowsToAdd - lNumBlankRows, 1).EntireRow.Insert
    End Select
    
    Set AddNBlankRowsAfterRange = rngAfter.Offset(rngAfter.Rows.Count, 0).Resize(lNumRowsToAdd, 1).EntireRow

End Function

Open in new window

You will then call it like this:
    Dim rngBlanks As Range

    Set rngBlanks = AddNBlankRowsAfterRange(20, pt.TableRange1)

Open in new window

and then join that to the pivot range using Union or Range, and do the grouping you want.
0
 
montrofAuthor Commented:
Thank you for all the help,

Have a great day,
Montrof
0
 
montrofAuthor Commented:
Sorry but i may have spoke too soon the add rows works great but the delete rows does not seem to work.  The objective would be if you are adding 20 rows but there is already 21 blank rows then it would delete one row.  IF you have 9 blank rows then it would add 11 rows  and so on.
0
 
montrofAuthor Commented:
I is deleting rows that have information in them because it is starting at the bottom of the range instead of the top.
0
 
montrofAuthor Commented:
I believe I figured it out and here is my solution

  Sub AddNBlankRowsAfterRange(ByVal lNumRowsToAdd As Long, ByRef rngAfter As range)

    Dim rngRowAfter As range
    Dim rngNextNonBlank As range
    Dim lNumBlankRows As Long
    
    If (rngAfter.Row + rngAfter.Rows.Count + lNumRowsToAdd - 1) > rngAfter.Worksheet.Rows.Count Then
        MsgBox "Not enough space on sheet to add " & CStr(lNumRowsToAdd) & " rows"
        Exit Sub
    End If
    
    ' get the first cell of the row after the range passed in
    Set rngRowAfter = rngAfter.EntireRow.Cells(1, 1)
    rngRowAfter.Select
    
    
    ' now find the next non-blank cell
    Set rngNextNonBlank = rngAfter.Worksheet.Cells.Find(What:="*", After:=rngRowAfter, SearchOrder:=xlByRows)
    
    lNumBlankRows = rngNextNonBlank.Row - rngAfter.Row
    
    ' if search wrapped round then there was no data below our range, so nothing to do
    Select Case lNumBlankRows
        Case Is > lNumRowsToAdd
            rngRowAfter.Resize(lNumBlankRows - lNumRowsToAdd, 1).EntireRow.Delete
        Case Is = lNumRowsToAdd
            ' nothing to do
        Case Is >= 0
            rngNextNonBlank.Resize(lNumRowsToAdd - lNumBlankRows, 1).EntireRow.Insert
    End Select
    
    Set rngRowAfter = rngAfter.Offset(rngAfter.Rows.Count, 0).Resize(lNumRowsToAdd, 1).EntireRow
    


End Sub

Open in new window

0
 
andrewssd3Commented:
OK - glad that works for you
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

  • 7
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now