How to insert (or create) new rows under every row that meets a certain condition?

khjhzw 

Sub insertrow()

Dim i As Integer
Dim j As Integer

For i = 1 To 1000

j = InStr(1, Cells(i, 1), "chapter", vbTextCompare)

If j = 1 Then
Cells(i + 1, 1).EntireRow.Insert
Cells(i + 2, 1).EntireRow.Insert

Cells(i + 1, 2).Value = "word count"
Cells(i + 2, 2).Value = "date started"

i = i + 2

Else
End If

Next i

End Sub

Maybe with these lines of code. Click the button in cell E1 in the attached file to start the macro.