Replace spacebar symbol with random word in VBA Word

Question

I've been stuck with this code for MS Word. My task is to change every spacebar in document with a random word from array.

I mean to put random word in document between every avaliable words. When I run my macros, it start to insert all words from array without any stop, so I must close Word to end cycle.

In example I use 5 words only, so my Rnd is from 1 to 4.

Sub TestRND()
    
    Const d = " "
    Dim x As Variant
    Randomize
    Selection.HomeKey wdStory
    x = Array(" Word1 ", " Word2 ", " Word3 ", " Word4 ", " Word5 ")
    With Selection
        .Find.Text = d
        .Find.MatchCase = True
        .Find.Font.Bold = False
        Do While .Find.Execute(Replace:=wdReplaceNone)
          .Range.HighlightColorIndex = wdYellow
          .Range.Text = x(Int((4 * Rnd) + 1))
        Loop
    End With
End Sub

So this is updated macros, i am using .Range.Style = "sss" but after that all words become green(color of style) and not all spacebars replaced.

Sub TestRND_StackOverflow()
    Const d = " "
    Dim x As Variant
    Dim Message, Title, Default, n
    Message = "From which page to start ?"    ' Set prompt.
    Title = "TestRND"    ' Set title.
    Default = "1"    ' Set default.
    ' Display message, title, and default value.
    n = InputBox(Message, Title, Default)
    'Selection.HomeKey wdStory
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=n ' RETURN TO DESIRED PAGE
    Randomize
    x = Array("Word1", "Word2", "Word3", "Word4", "Word5")
    With Selection
        .Find.Text = d
        .Find.MatchCase = True
        .Find.Font.Bold = False
        Do While .Find.Execute(Replace:=wdReplaceNone)
          .InsertBefore " " & x(Int((4 * Rnd) + 1))
          .MoveStartUntil " "
          .Range.Style = "sss"
          .Collapse wdCollapseEnd
        Loop
    End With
       ActiveDocument.SpellingChecked = True
       MsgBox "Finish", vbInformation
End Sub

Answer 1

For example:

Sub TestRND()
    
    Const d = " "
    Dim x As Variant
    Randomize
    Selection.HomeKey wdStory
    x = Array("Word1", "Word2", "Word3", "Word4", "Word5")
    With Selection
        .Find.Text = d
        .Find.MatchCase = True
        .Find.Font.Bold = False
        Do While .Find.Execute(Replace:=wdReplaceNone)
          .InsertBefore " " & x(Int((4 * Rnd) + 1))
          .MoveStartUntil " "
          .Range.HighlightColorIndex = wdYellow
          .Collapse wdCollapseEnd
        Loop
    End With
End Sub