Solved

Space and grouping after pivot table

Posted on 2013-05-16
12
282 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
  • 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
 
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
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
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

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Suggested Solutions

What is a Form List Box? (skip if you know this) The forms List Box is the alternative to the ActiveX list box. If you are using excel 2007, you first make sure you have a developer tab (click the Orb)->"Excel Options"->Popular->"Show Developer tab…
Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

708 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

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now