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

(Joanne) wrote in message . com...
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