Learn how to a build a cloud-first strategyRegister Now

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

Need VBA to select Sub-total rows only

Hi Experts,

I've attached a file with a couple of sheets that are part of a larger project. The procedure I am having difficulty with is activated by the "Team Totals" button on the "Summary Data" worksheet (which produces the "Team Totals" worksheet with some Subtotals calculated - to run same, make sure to delete the existing Team Totals worksheet first).

What I am trying to do is this:  The spreadsheet user has indicated that the "Team" Subtotals aren't meaningful but in their place on the inserted Subtotal Rows, he would like to see the last quarterly totals for the Team rather than a sum of the DataSet. Manually, I can do this by:

1) collapsing the outline to the Team Totals (Outline Level 3), and then
2) selecting the cells in those subtotals rows,
3) doing a Goto (F5) Special | Visible Cells (though this last probably isn't necessary),
4) then expanding the outline to the Full detail (Outline Level 5),
5) in the active cell, typing the formula "=" followed by an Up Arrow key, and
6) finishing the formula with a CTRL+Enter to update all of the selected visible cells, with their own relative formula to retrieve the last quarter's value for the Team.

However, I can't figure out a way to dynamically (with VBA) determine the Sub-total rows only to apply this treatment to.  This is the main problem I am trying to solve.

For extra credit ;~), I'm also having these issues:

a) When I get that part finished, I want to copy and paste the entire sheet as Values (but I've been getting "The information cannot be pasted because the copy area and the paste area are not the same size and shape..." etc. errors doing that (I guess because either a filter or Sub-totals have been applied when I've done that).  

b) Somehow in my code, I have added an "extra" level to the outline that is not functional (clicking same - Level 2 - shows no data), and when the existing procedure finishes, it seems to have super-imposed a level with all of the blank rows that weren't populated with data and that needs to go away ...

If someone can assist with the VBA to fix these things, too, that would be great.

Thanks for any insights!

(BTW, while I am using Excel 2007 on this project, since EE won't accept an "XLSM" file as an attachment, I have saved the file as an XLS format)

Jeff


EE-example.zip
0
jeffreywsmith
Asked:
jeffreywsmith
  • 9
  • 3
1 Solution
 
Rory ArchibaldCommented:
Do you want the formula change applied to all columns?
Also, I don't follow part B of your supplementary question - can you elaborate?

Thus far, I have merely tidied up your code a bit as below.

Sub teamTotals()
    Dim lastrow As Long
    Dim wksData As Worksheet, wksTotals As Worksheet
    Dim lngCalc As Long
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Team Totals Report").Delete
    Application.DisplayAlerts = True
'    On Error GoTo err_handle

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    Set wksData = Sheets("Summary Data")
    wksData.Copy Before:=Sheets("Summary Data")
    Set wksTotals = Sheets("Summary Data (2)")
    With wksTotals
        .Name = "Team Totals Report"
        .Range("A4:Y" & .Rows.Count).Clear
        .Range("V3:Y3").Clear
    End With
    
    With wksData
        lastrow = .Cells(.Rows.Count, 21).End(xlUp).Row
        .Range("A4:U" & lastrow).Copy wksTotals.Range("A4")
    End With
    With wksTotals
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=.Range("B4:B" & lastrow), SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=.Range("A4:A" & lastrow), SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=.Range("C4:C" & lastrow), SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, DataOption:=xlSortNormal
            End With
            
            .SetRange .Range("A3:S" & lastrow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With ' .Sort

        lastrow = .Cells(.Rows.Count, 21).End(xlUp).Row
    
        On Error Resume Next
    
        .Shapes("Button 1").Cut
        .Shapes("Button 2").Cut
        .Shapes("Button 3").Cut
        .Shapes("Button 4").Cut
        .Shapes("Button 5").Cut
    
        On Error GoTo 0
        
        .Range("A3:U" & lastrow).Subtotal GroupBy:=2, Function:=xlSum, _
                                TotalList:=Array(5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21), _
                                Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        .Outline.ShowLevels RowLevels:=2
    
        With .Range("O2:V2")
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            .Borders(xlEdgeTop).LineStyle = xlNone
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
    
        With .Tab
            .ThemeColor = xlThemeColorAccent6
            .TintAndShade = 0.399975585192419
        End With
        
        .Range("A:A").ColumnWidth = 21.29
        .Range("Z:AA").Clear
    
        With .Range("T2")
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlNone
            .Borders(xlEdgeTop).LineStyle = xlNone
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
        
        .Columns("A:A").ColumnWidth = 26
        .Columns("N:N").ColumnWidth = 10.57
        .Columns("T:T").ColumnWidth = 12
    
        ActiveWindow.Zoom = True
    
        lastrow2 = .Cells(.Rows.Count, "U").End(xlUp).Row
        .Range("A3:U" & lastrow2).Subtotal GroupBy:=1, Function:=xlSum, _
                            TotalList:=Array(5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21), _
                            Replace:=False, PageBreaks:=False, SummaryBelowData:=True
        .Columns("N:N").ColumnWidth = 10.43
    
        .Range("$A$3:$U$332").AutoFilter Field:=2, Criteria1:="=Team*", _
            Operator:=xlAnd, Criteria2:="=*Total"
            
    End With ' wksTotals

    MsgBox "Report Complete.", vbInformation Or vbDefaultButton1, "Team Reporting Message"
    
clean_up:
    With Application
        .EnableEvents = True
        .Calculation = lngCalc
        .ScreenUpdating = True
    End With

    Exit Sub

err_handle:

MsgBox Err.Description
Resume clean_up

End Sub

Open in new window

0
 
jeffreywsmithAuthor Commented:
Hi Rory - thanks for posting!

I want to change the formulas in columns E:U for all Team Sub-total rows.  As far as part b) you should be able to see that clicking the Level 2 outline button will display ... nothing. Also related I think, is that when you look at the Team Totals Report worksheet when my original macro finished, you will see that while the Team Total rows are collapsed, there is an apparent 'outside' level that extends from row 43 to row 333 (mostly blank rows). Something I introduced by how I selected the data, I think but I don't know how to get rid of it.

Jeff
0
 
Rory ArchibaldCommented:
I'll have a look.
In the meantime, is there a reason for not using a pivot table? They are infinitely superior to subtotals, IMO.
Rory
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!

 
jeffreywsmithAuthor Commented:
I'll tell you the truth, Rory: I've likely missed out on a formal education on the proper use of PT's but muddled my way through it at one time while creating with code a reporting system that generated hundreds of PT's, but I walked away from the experience with a bad taste in my mouth ;-( ... so to speak.  I'd love to be able to automate a PT report on this data set but I can't even seem to be able to do it manually.

Jeff
0
 
jeffreywsmithAuthor Commented:
Re: PT's ... again, I'm using Excel 2007 if that makes any difference here.

Jeff
0
 
jeffreywsmithAuthor Commented:
Bump.  Rory, I've tried your code, but obviously, it stops short of where I need to go with this ...

Am getting a bit desperate here.

Jeff
0
 
jeffreywsmithAuthor Commented:
Ok - I think I've resolved "the main problem I am trying to solve" (to dynamically (with VBA) determine the Sub-total rows only to apply this treatment to).  I'll post back with some code when I finish here (but didn't want anyone to waste any time with that part of it). In the meantime, I'm on to try and fix "issue b)" from above.  So, feel free to have at that, Rory, or if you're feeling extra frisky, I'd love to see what you might do with a Pivot Table here ;~),

Jeff
0
 
Rory ArchibaldCommented:
OK but won't be for a while as I am looking after my daughter today and will be away in London for the next two days..
0
 
jeffreywsmithAuthor Commented:
Ok, so I've also got "issue b)" resolved now, too.  This was the code I added to find the Sub-total rows only and modify their calculations to retrieve just the preceding row of data:

Dim currRow As Long, cel As Range, cel2 As Range

lastrow2 = Cells(1048576, 17).End(xlUp).Row

For Each cel In Range("B3:B" & lastrow2)
If Left(cel.Value, 4) = "Team" And Right(cel.Value, 5) = "Total" Then
    currRow = cel.Row
    For Each cel2 In Range("E" & currRow & ":" & "U" & currRow)
    cel2.FormulaR1C1 = "=R[-1]C"
    Next cel2
End If
If cel.Value = "Grand Total" Then cel.EntireRow.Delete
Next cel

Guess you've gotten distracted but I'd still be interested in any PT solution you might have here, Rory.

Jeff
0
 
jeffreywsmithAuthor Commented:
Guess our posts crossed - Ok, Rory ... hope to hear from you when you get a chance.

Thanks,

Jeff
0
 
jeffreywsmithAuthor Commented:
Hi Rory,

I am ready to close this out ... as my immediate problem is solved ... but I am always willing to learn something (and Pivot Tables have almost always frustrated me).  I know you are a busy guy so if you want me to close this out, I'll do so ... otherwise, I'll wait until you get back to this.

Jeff
0
 
jeffreywsmithAuthor Commented:
Ok, past time to close this out ... Rory, thanks for your help.  If you get around to posting that PT solution, I'd be glad to see it.

Regards,

Jeff
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 9
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now