Sub ShowCorrectAnswer() 
     '
     ' ShowCorrectAnswer Macro
     '
    With Selection.Find 
        .Format = False 
        .MatchCase = True 
        .MatchWholeWord = False 
        .MatchWildcards = False 
        .MatchSoundsLike = False 
        .MatchAllWordForms = False 
    End With 
    Selection.HomeKey Unit:=wdStory 
    Do 
        Selection.Find.ClearFormatting 
        Selection.Find.Replacement.ClearFormatting 
        With Selection.Find 
            .Text = ") is correct." 
            .Replacement.Text = "} is correct." 
            .Forward = True 
            .Wrap = wdFindStop 
        End With 
        If Not Selection.Find.Execute(Replace:=wdReplaceOne) Then Goto Finish 
        Selection.Collapse direction:=wdCollapseStart 
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend 
        Selection.Copy 
        Selection.Find.ClearFormatting 
        Selection.Find.Replacement.ClearFormatting 
        With Selection.Find 
            .Text = "Answer (A)" 
            .Replacement.Text = "" 
            .Forward = False 
            .Wrap = wdFindAsk 
        End With 
        Selection.Find.Execute 
        Selection.Collapse direction:=wdCollapseStart 
        Selection.TypeText Text:="Answer: " 
        Selection.PasteAndFormat (wdFormatOriginalFormatting) 
        Selection.TypeParagraph 
    Loop 
Finish: 
    Selection.HomeKey Unit:=wdStory 
    Selection.Find.ClearFormatting 
    Selection.Find.Replacement.ClearFormatting 
    With Selection.Find 
        .Text = "} is correct." 
        .Replacement.Text = ") is correct." 
        .Forward = True 
        .Wrap = wdFindStop 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll 
End Sub