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

  • Thread starter Thread starter Joanne
  • Start date Start date
J

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
 
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
 
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.
 
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
Click to expand...

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
 
Looking for some help…. I am using the following macro to insert a blank row (to separate varying Group rows) and then, Subtotal Column B per each Group:
Sub GroupInsertRowAndTotal()
Dim lngRow As Long, lngStart As Long
lngStart = 2: lngRow = lngStart
Do: lngRow = lngRow + 1
If Range("A" & lngRow) <> Range("A" & lngRow - 1) Then
Rows(lngRow).Insert
Range("B" & lngRow) = "=SUM(B" & lngStart & ":B" & lngRow - 1 & ")"
'Remark the below line if you want to convert the formulas to actual values.
'Range("B" & lngRow).Value = Range("B" & lngRow)
lngRow = lngRow + 1: lngStart = lngRow
End If
Loop Until Range("B" & lngRow) = ""
End Sub

If possible and practical, I would like to edit the above with additional VBA code using the respective “Subtotal” generated above to populate Column M (starting in row 2) with the following formula:

=(1-(b2/$b$13))/(b2/$b$13); =(1-(b3/$b$13))/(b3/$b$13); =(1-(b4/$b$13))/(b4/$b$13); (etc.)

[Note 1: Same formula calculation for cells (b2:b12) and for illustration purposes only, $b$13 = the cell location of the first Subtotal…. Then, repeat based on cell location of next Subtotal…. RE: All columns are “blank” in each Subtotal row except for Column B]

I am trying to automate current daily spreadsheet that usually has in excess of 1000 rows which doing manually, is obviously very time consuming…. I am new to VBA and any help would be greatly appreciated.

Thanks in advance,

KWL
 
Back
Top