Maybe:

Sub percuk17()
Dim rcell As Range, x As Range, y As Range, z As Long
z = Range("A" & Rows.Count).End(3).row
For Each rcell In Range("A1:A" & z)
    If Right(rcell, 9) = "BEGINNING" Then
        Set x = Range(Cells(rcell.row + 1, 1), Cells(z, 1)).Find("END", LookIn:=xlValues, lookat:=xlPart)
            If Not x Is Nothing Then
                For Each y In Range(Cells(rcell.row + 1, 1), Cells(x.row - 1, 1))
                    y = y & " BETWEEN"
                Next y
            End If
        Set x = Nothing
    End If
Next rcell
End Sub