Using VBA, subtotal a column only if there is more than one qualifier

[Joanne]

I need to do a subtotal for a very large spreadsheet, but I don't want
to subtotal the numbers when there is only one qualifier since it is a
little redundant. Essentially a summarized version of my spreadsheet
is:
A B
101 25
101 27
101 89
201 45
301 96
301 37

What I want the macro to do is; subtotal Column B for every change in
column A except when Column A only has one qualifier, therefore the
final spreadsheet should look something like this:
A B
101 25
101 27
101 89
Sum 101 141
201 45
301 96
301 37
Sum 301 133
Any help would be very appreciated and Thank-you in advace.
Joanne

 

[Ken Wright]

The other thing you might consider depending on your data, is a Pivot Table. Probably one of the
most flexible and powerful tools Excel has, yet so simple to use. Debra Dalgleish has a good
intro at the following link:-

http://www.geocities.com/jonpeltier/Excel/Pivots/pivotstart.htm

 

[joanne mckinstry]

I am unable to use the Data/Subtotal function since my spreadsheet is so
large and I have many, many columns. About 50% of the rows have a
single qualifier so I do not want to subtotal them. If I use the
data/Subtotal function, my spreadsheet will look something like this
A B C D
101 25 cf a
101 26 df b
101 30 cf c
Sum 101 81
201 96 df d
Sum 201 96
301 87 if e
301 45 xl f
Sum 301 132
When I hit the buttons to hide the specific subtotals it does not hide
the SUM line it hides the line with all the information and I need to
see the information in the "c" and "d" column. Pivot tables will not
work since I have too much information to put on one. In total the
spreadsheet has about 30 columns and I want to subtotal 2 of the columns
only if they have more than one qualifier. So coniserdering the real
spreadsheet I am working with has about 1000 rows and 30 or so columns,
I think that the best way to go is programming. I hope I got specific
enough and I hope that you are able to help. I know how to Subtotal more
than one column, my only problem is writting the macro that will ignore
lines that have one qualifier.
Thank-you so much for any help

*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

 

[Dave Peterson]

How about this:

Insert headers into row 1 first.

Then insert a new column A. Fill that range with 1's.

Apply data|subtotal
Copy column A
edit|paste special values

Filter on that column for 1's and filter on column B for "*subtotal".

Delete those 1's that you see.

Remove the filter and delete column A.

Here's what I got:

Option Explicit
Sub testme01()

Dim wks As Worksheet
Dim LastRow As Long
Dim myRng As Range

Set wks = ActiveSheet

With wks

.AutoFilterMode = False
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Columns(1).Insert
.Range("A2:a" & LastRow).Value = 1

'30 columns + one inserted
Set myRng = .Range("a1:a" & LastRow).Resize(, 31)

Application.DisplayAlerts = False
myRng.Subtotal groupby:=2, Function:=xlSum, totallist:=Array(1, 3), _
Replace:=True, pagebreaks:=False, _
summarybelowdata:=xlSummaryBelow
Application.DisplayAlerts = True

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set myRng = .Range("a1:a" & LastRow)

.Columns(1).Value = .Columns(1).Value

myRng.RemoveSubtotal

myRng.Resize(, 2).AutoFilter field:=1, Criteria1:="1"
myRng.Resize(, 2).AutoFilter field:=2, Criteria1:="*total"

On Error Resume Next
myRng.Offset(1, 0).Resize(myRng.Rows.Count - 1, 1) _
.Cells.SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0

.AutoFilterMode = False
.Columns(1).Delete
End With

End Sub

Alternatively, you could start at the bottom and just loop your way up:

Option Explicit
Sub testme02()

Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim botCell As Range
Dim topCell As Range
Dim wks As Worksheet

Set wks = ActiveSheet

With wks
FirstRow = 2
.Rows(FirstRow).Insert
.Cells(FirstRow, "A").Value = "dummyVal"
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

Set topCell = .Cells(LastRow, "A")
Set botCell = .Cells(LastRow, "A")
For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
Set topCell = .Cells(iRow - 1, "A")
Else
If topCell.Address = botCell.Address Then
'do nothing
Else
botCell.Offset(1, 0).EntireRow.Insert
botCell.Offset(1, 1).Formula _
= "=subtotal(9," & topCell.Offset(0, 1).Address(0, 0) _
& ":" & botCell.Offset(0, 1).Address(0, 0) & ")"
botCell.Offset(1, 0).Value = "Subtotal: " & botCell.Value
End If
Set botCell = .Cells(iRow - 1, "A")
Set topCell = .Cells(iRow - 1, "A")
End If
Next iRow

.Rows(FirstRow).Delete

End With

End Sub

I did insert a dummyVal in a new row--to make checking that final group easier.
I delete it when I'm done.

 

[Phillip R]

I need to do a subtotal for a very large spreadsheet, but I don't want
to subtotal the numbers when there is only one qualifier since it is a
little redundant. Essentially a summarized version of my spreadsheet
is:
A B
101 25
101 27
101 89
201 45
301 96
301 37

What I want the macro to do is; subtotal Column B for every change in
column A except when Column A only has one qualifier, therefore the
final spreadsheet should look something like this:
A B
101 25
101 27
101 89
Sum 101 141
201 45
301 96
301 37
Sum 301 133
Any help would be very appreciated and Thank-you in advace.
Joanne

Assuming that there is a continuous column of numbers starting with A1
and a list of numbers in column B, then this code worked for me

Sub DoSubTotal()
Dim rng As Range
Dim k As Integer
Dim kntdups As Integer

Set rng = Range("A:A")
k = 1
kntdups = 0
Do While rng.Cells(k).Value <> ""
Do
If rng.Cells(k) = rng.Cells(k + 1) Then
kntdups = kntdups + 1
k = k + 1
Else
If kntdups >= 1 Then
With rng
.Cells(k + 1).EntireRow.Insert
.Cells(k + 1) = "Subtotal " & .Cells(k)
..Cells(k + 1).Offset(0, 1).FormulaR1C1 = "=SUM(R[-" & kntdups + 1 & "]C:R[-1]C)"
End With
kntdups = 0
k = k + 2
Else
kntdups = 0
k = k + 1
End If
End If
Loop Until kntdups = 0
Loop
End Sub