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

Graham

Tom Ogilvy wrote:
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