Sub Move_Two_Lines_Down()

Dim Rng As range

Set Rng = selection.range

Application.ScreenUpdating = False

    Do
        With Rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .text = "Keywords ^#"
            .Forward = True
            .Format = True
            .Wrap = wdFindStop
            .MatchWildcards = False
            .Execute
            If Rng.End > selection.range.End Then Exit Do
            If .found Then
                Rng.Paragraphs(1).range.Cut
                Rng.Move unit:=wdParagraph, count:=2
                Rng.Paste
                Rng.Collapse wdCollapseEnd
            Else: Exit Do
            End If
        End With
    Loop
Application.ScreenUpdating = True
Set Rng = Nothing
End Sub