Find a word in a cell and delete certain rows bellow

I am working in a macro that finds a specific word (Subtotal) in a cell and delete the entire row. But I need to delete as well the next consecutive 6 rows all along the same column range B.

What I have done so far works well but it just deletes the current row and I need to delete the next 6 as well whenever the word "Subtotal" is found.

This is my code:

Sub DeleteRows()
Dim c As Range
Dim SrchRng

Set SrchRng = ActiveSheet.Range("B1", ActiveSheet.Range("B1200").End(xlUp))
Sheets("2014").Select
Do


Set c = SrchRng.Find("Subtotal", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.delete



Loop While Not c Is Nothing


Set SrchRng = ActiveSheet.Range("C1", ActiveSheet.Range("C1200").End(xlUp))
Do
Set c = SrchRng.Find("Subtotal", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.delete
Loop While Not c Is Nothing
End Sub

Could you please help me to resolve this?