Sub q1()
    Application.ScreenUpdating = False
   Randomize
   Set MyRange = ThisDocument.Content
    With MyRange
        With .Find
            .ClearFormatting
            .Font.Name = "Times New Roman"
            .Text = "(?)"
            '.Replacement.Text = "\1"
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = True
            .Execute
            If Not MyRange Is Nothing Then
                Start = MyRange.Start
                With MyRange.Font
                   .Size = .Size + Round(Rnd() + 1, 0) * IIf(Round(Rnd(), 0) = 0, -1, 1)
                End With
                Do
                    .Execute
                    If MyRange Is Nothing Then Exit Do
                    With MyRange.Font
                        .Size = .Size + Round(Rnd() + 1, 0) * IIf(Round(Rnd(), 0) = 0, -1, 1)
                    End With
                Loop While MyRange.Start <> Start
            End If
        End With
    End With
    Application.ScreenUpdating = True
End Sub