Solved

Space and grouping after pivot table

Posted on 2013-05-16
12
314 Views
Last Modified: 2013-05-17
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
Comment
Question by:montrof
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 7
  • 5
12 Comments
 
LVL 17

Expert Comment

by:andrewssd3
ID: 39174335
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
 
LVL 17

Expert Comment

by:andrewssd3
ID: 39174346
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
 
LVL 1

Author Comment

by:montrof
ID: 39174502
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
Independent Software Vendors: 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!

 
LVL 1

Author Comment

by:montrof
ID: 39174513
I also want to group the new range.  Sorry I forgot to say that.
0
 
LVL 17

Expert Comment

by:andrewssd3
ID: 39174657
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
 
LVL 1

Author Comment

by:montrof
ID: 39174690
That is very close except for I need it to include the pivot table in the range it is grouping
0
 
LVL 17

Accepted Solution

by:
andrewssd3 earned 500 total points
ID: 39174822
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
 
LVL 1

Author Closing Comment

by:montrof
ID: 39174853
Thank you for all the help,

Have a great day,
Montrof
0
 
LVL 1

Author Comment

by:montrof
ID: 39175141
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
 
LVL 1

Author Comment

by:montrof
ID: 39175362
I is deleting rows that have information in them because it is starting at the bottom of the range instead of the top.
0
 
LVL 1

Author Comment

by:montrof
ID: 39175432
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
 
LVL 17

Expert Comment

by:andrewssd3
ID: 39175632
OK - glad that works for you
0

Featured Post

Industry Leaders: 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!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

756 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question