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

x
?
Solved

VBA Code to Total Columns by Groups

Posted on 2009-05-06
14
Medium Priority
?
361 Views
Last Modified: 2013-11-10
For each Column Sum the total and
Depending upon the number of Groups
Sumif the Total for each Group under the Column Total
The column number is fixed but the number of groups can vary                                      
0
Comment
Question by:llawrenceg
  • 5
  • 4
  • 4
  • +1
14 Comments
 
LVL 19

Expert Comment

by:david251
ID: 24318761
It would be helpful to have the worksheet that you are trying to sum
-David251
0
 
LVL 19

Expert Comment

by:david251
ID: 24319285
In absence of the file perhaps this will help you a bit.  

Select the range including the column header of the single column which has the Group Names.

Then adjust the intColumnSumOffset.  This is the data you want to sum.  

So if your group column is C1:C10 and the data is D1:D10 then intColumnSumOffset=1 since D is one column to the left of C

HTH,

-David251
Sub subFilterUniqueSubtotal()
    
    Dim intColumnSumOffset As Integer
'Enter an offset for column to sum
    intColumnSumOffset = 1
 
    Dim rng As Range
    Set rng = Selection
    
    If rng.Columns.Count > 1 Then
        MsgBox "You have selected more than one column. Aborting", vbOKOnly
        Exit Sub
    End If
    If rng.Rows.Count = 1 Then
        MsgBox "Please select your data. Aborting", vbOKOnly
        Exit Sub
    End If
    
    Dim rngDest As Range
    
    Set rngDest = Cells(rng.Row + rng.Rows.Count + 4, rng.Column)
    rngDest.ClearContents
    rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngDest, Unique:=True
    Range(rngDest.Offset(1, intColumnSumOffset), _
        rngDest.End(xlDown).Offset(0, intColumnSumOffset)).Formula = "=SUMPRODUCT((" & rngDest.Offset(1, 0).Address(False, True) & "=" & rng.Offset(1, 0).Address & ")*" & rng.Offset(1, intColumnSumOffset).Address(True, False) & ")"
    
End Sub

Open in new window

0
 
LVL 45

Expert Comment

by:patrickab
ID: 24319713
llawrenceg,

Please ask for one of these questions to be deleted as you cannot off more than 500 points for a question.
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q__24386395.html 
For each Column Sum the total and
Depending upon the number of Groups
Sumif the Total for each Group under the Column Total
The column number is fixed but the number of groups can vary
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q__24386398.html 
For each Column Sum the total and
Depending upon the number of Groups
Sumif the Total for each Group under the Column Total
The column number is fixed but the number of groups can vary
Patrick
 
0
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 

Author Comment

by:llawrenceg
ID: 24319907
Attached is a Sample file to work with and some of the code I have tried
Sub CreateTotals2()
 
Dim t As Integer
Dim c As Range
Dim col As Integer
Dim cols As Integer
 
Set c = ActiveSheet.Cells(Cells.Rows.Count, 29).End(xlUp).Offset(1, 0)
col = ActiveSheet.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
 
For t = 0 To 5
 
    If t = 0 Then
        c = "Totals"
        For col = 30 To 36
            c.Offset(0, col - 1) = "=ROUND(SUM(" & Cells(1, col).Address(False, False) & ":" & c.Offset(-1, col - 1).Address(False, False) & "),2)"
        Next col
    Else
        c.Offset(t, 0) = "Group " & t & " Total"
        For col = 30 To 36
            c.Offset(t, col - 1) = "=ROUND(SUMIF(AC5:AC" & c.Row - 1 & ",""" & "=" & t & """," & Cells(1, col).Address(False, False) & ":" & c.Offset(-1, col - 1).Address(False, False) & "),2)"
        Next col
    End If
 
Next t
 
End Sub

Open in new window

Book2.xls
0
 

Author Comment

by:llawrenceg
ID: 24319988
The main issue is that the code needs to determine the number of groups and run alog side some other coding
0
 
LVL 33

Expert Comment

by:jppinto
ID: 24320000
Did you've checked my file on the other duplicate question? See if this is what you want to do.

jppinto

Q24386398.xls
0
 
LVL 19

Expert Comment

by:david251
ID: 24320022
That is precisely what my code does.

It auto filters the unique values from your data.
0
 
LVL 19

Expert Comment

by:david251
ID: 24320075
Try this:
Sub subFilterUniqueSubtotal()
    
    Dim intColumnSumOffset As Integer
'Enter an offset for column to sum
    intColumnSumOffset = 1
 
    Dim rng As Range
    Set rng = Range("AD5:AD22")
    
    Dim rngDest As Range
    
    Set rngDest = Cells(rng.Row + rng.Rows.Count + 2, rng.Column)
    rngDest.ClearContents
    rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngDest, Unique:=True
 
for  intColumnSumOffset = 1 to 7
    Range(rngDest.Offset(1, intColumnSumOffset), _
        rngDest.End(xlDown).Offset(0, intColumnSumOffset)).Formula = "=SUMPRODUCT((" & rngDest.Offset(1, 0).Address(False, True) & "=" & rng.Offset(1, 0).Address & ")*" & rng.Offset(1, intColumnSumOffset).Address(True, False) & ")"
next intColumnSumOffset
End Sub

Open in new window

0
 

Author Comment

by:llawrenceg
ID: 24327452
David:
I tried your code and it just repeats all of the rows  down below the existing rows.
There needs to be a total for each column  then
below the total for each column there needs to be a total for each group for each column

Total             xxxxxx  xxxxxx xxxxxx xxxxxx xxxxxx xxxxxx xxxxxx
Group1 Total xxxxxx xxxxxx xxxxxx xxxxxx xxxxxx xxxxxx  xxxxxx
Group2 Total xxxxxx xxxxxx xxxxxx  xxxxxx xxxxxx xxxxxx xxxxxx
Group3  Total xxxxxx xxxxxx xxxxxx  xxxxxx xxxxxx xxxxxx xxxxxx
etc                  etc          etc        etc
0
 
LVL 45

Expert Comment

by:patrickab
ID: 24331714
llawrenceg,
The macro below is in the attached file. ALT+F8 to select and run the macro. It will cope with different numbers of groups automatically.
Hope it helps
Patrick

Sub specialmacro()
Dim rng As Range
Dim celle As Range
Dim str1 As String
Dim str2 As String
Dim rowe As Long
Dim lastrow As Long
Dim i As Long
Dim n As Long
Dim coll As New Collection
 
With Sheets("Sheet1")
    For i = 5 To 1000
        If .Cells(i, "B") = "Total" Then
            lastrow = i - 1
            Exit For
        End If
    Next i
    
    For i = 1 To 7
        .Cells(lastrow + 1, i + 2).FormulaR1C1 = "=SUM(R5C:R[-1]C)"
    Next i
 
    Set rng = Range(.Cells(5, "B"), .Cells(lastrow, "B"))
    
    For Each celle In rng
        On Error Resume Next
        coll.Add CStr(celle), CStr(celle)
    Next celle
    
    For i = 1 To coll.Count
        .Cells(lastrow + 2 + i, "B") = --coll(i)
    Next i
    
    For i = 1 To coll.Count
        For n = 3 To 9
            .Cells(lastrow + 2 + i, n).FormulaR1C1 = "=SUMIF(R5C2:R22C2,RC2,R5C:R22C)"
        Next n
    Next i
    
    For n = 3 To 9
        .Cells(lastrow + 2 + coll.Count + 1, n).FormulaR1C1 = "=SUM(R[" & -coll.Count & "]C:R[-1]C)"
    Next n
    
End With
 
End Sub

Open in new window

llawrenceg-01.xls
0
 

Author Comment

by:llawrenceg
ID: 24347079
The "Total" and "Group Total " Labels need to be addd to the Column as the number of items in the column is vaiiable
0
 
LVL 45

Accepted Solution

by:
patrickab earned 2000 total points
ID: 24347167
llawrenceg,
See attached file.
Patrick

Sub specialmacro()
Dim rng As Range
Dim celle As Range
Dim str1 As String
Dim str2 As String
Dim rowe As Long
Dim lastrow As Long
Dim i As Long
Dim n As Long
Dim coll As New Collection
 
Application.ScreenUpdating = False
With Sheets("Sheet1")
    lastrow = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
    .Cells(.Cells.Rows.Count, "B").End(xlUp).Offset(1, 0) = "Total"
    .Cells(.Cells.Rows.Count, "B").End(xlUp).Offset(1, 0) = "Group Total"
    
    For i = 1 To 7
        .Cells(lastrow + 1, i + 2).FormulaR1C1 = "=SUM(R5C:R[-1]C)"
        .Cells(lastrow + 1, i + 2).NumberFormat = "[$$-409]#,##0.00"
    Next i
 
    Set rng = Range(.Cells(5, "B"), .Cells(lastrow, "B"))
    
    For Each celle In rng
        On Error Resume Next
        coll.Add CStr(celle), CStr(celle)
    Next celle
    
    For i = 1 To coll.Count
        .Cells(lastrow + 2 + i, "B") = --coll(i)
    Next i
    
    For i = 1 To coll.Count
        For n = 3 To 9
            .Cells(lastrow + 2 + i, n).FormulaR1C1 = "=SUMIF(R5C2:R22C2,RC2,R5C:R22C)"
            .Cells(lastrow + 2 + i, n).NumberFormat = "[$$-409]#,##0.00"
        Next n
    Next i
    
    For n = 3 To 9
        .Cells(lastrow + 2 + coll.Count + 1, n).FormulaR1C1 = "=SUM(R[" & -coll.Count & "]C:R[-1]C)"
        .Cells(lastrow + 2 + coll.Count + 1, n).NumberFormat = "[$$-409]#,##0.00"
    Next n
    
End With
 
End Sub

Open in new window

llawrenceg-02.xls
0
 

Author Closing Comment

by:llawrenceg
ID: 31578684
works perfectly and I learned something as well
0
 
LVL 45

Expert Comment

by:patrickab
ID: 24352530
llawrenceg - Thanks for the grade - Patrick
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

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

Q&A with Course Creator, Mark Lassoff, on the importance of HTML5 in the career of a modern-day developer.
When you discover the power of the R programming language, you are going to wonder how you ever lived without it! Learn why the language merits a place in your programming arsenal.
In this fourth video of the Xpdf series, we discuss and demonstrate the PDFinfo utility, which retrieves the contents of a PDF's Info Dictionary, as well as some other information, including the page count. We show how to isolate the page count in a…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

927 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