Sub Makro7()
Dim oRng As Range
Dim oFound As Range
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(FindText:="Chapter")
            Set oFound = oRng
            oRng.Collapse 0
            oRng.Fields.Add oRng, wdFieldSequence, "ChapterNum", False
            oRng.InsertBefore Chr(32)
            oFound.End = oRng.End
            oFound.Style = "Heading 1"
            oRng.Collapse 0
        Loop
    End With
End Sub