Print Subtotals of variable entries

[Graham Haughs]

The procedure below was used to print out blocks of data on individual
sheets based on the entries in Column B. It has been changed but for the
purposes of my query it is perhaps simpler to use this one. In column P
there are number entries. The number of rows printed will vary depending
on the entries in Column B. eg if B5,B6 and B7 have the same value then
the printout will be of three rows plus the headers. What I would like
is to have this printout but with the total of the figures in column P.
So if B5, B6 and B7 were Field 1 and C5,C6 and C7 were 1,2 and 3 the
printout would show these figures with the subtotal 6 below the
individual entries. I know a pivot table will create this but I thought
this would dramatically complicate something that already prints out
fine. I value as always any guidance.

Dim cell As Range
Dim lCount As Long
Dim rCol As Range
'Get the last cell in column B
With Sheets("Field Records")
Set rCol = .Range("B10", .Range("B" & .Rows.Count).End(xlUp))
End With
'Loop through column B
For Each cell In rCol.Cells
'If a new value
If cell.Value <> cell.Offset(-1, 0).Value Then
'Count the number of similar values in col B
lCount = Application.CountIf(rCol, cell.Value)
'Resize a range and print it out
cell.Resize(lCount, 17).PrintOut
End If
Next cell

Kind regards
Graham Haughs
Turriff, Scotland

 

[Tom Ogilvy]

Dim cell As Range
Dim lCount As Long
Dim rCol As Range
Dim sh as Worksheet, sh1 as Worksheet
Dim rng as Range
set sh = Sheets("Field Records")
worksheets.Add After:=Worksheets(worksheets.count)
set sh1 = Activesheet
sh.Activate
'Get the last cell in column B
With sh
Set rCol = .Range("B10", .Range("B" & .Rows.Count).End(xlUp))
End With
'Loop through column B
For Each cell In rCol.Cells
'If a new value
If cell.Value <> cell.Offset(-1, 0).Value Then
'Count the number of similar values in col B
lCount = Application.CountIf(rCol, cell.Value)
'Resize a range and print it out
sh1.Cells.Clear
cell.Resize(lCount, 17).EntireRow.copy sh1.Range("A1")
set rng = sh1.Cells(lcount + 1,"P")
rng.FormulaR1C1 = "=Sum(R1C:R[-1]C)"
sh1.cells(lcount+1,1).Resize(,17).printout
End If
Next cell
Application.DisplayAlerts = False
sh1.Delete
Application.DisplayAlerts = True

 

[Graham Haughs]

Tom, you are, as always, staggeringly amazing.
Many thanks.

Graham