Macro to make line of text red

[charliew001]

Hi All,

I have attached a copy of my document. I have a few hundred pages of these questions and will be creating more in the future. I am looking for a macro that will make the correct answer choice red. If you look in the file, you will see that there is a line indicating "Correct Answer: A". I am hoping that the macro would possibly make the answer choice "A" that preceded that line in red.

8338

Thank You

[macropod]

Try:
Sub Demo()
Application.ScreenUpdating = False
Dim RngDoc As Range, RngOld As Range, RngNew As Range, StrTxt As String
Set RngDoc = ActiveDocument.Range
Set RngOld = ActiveDocument.Range(0, 0)
With RngDoc
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Correct Answer:[!^13]{1,}[^13]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
Set RngNew = RngDoc.Duplicate
RngNew.End = RngNew.End - 1
StrTxt = Split(RngNew.Text, " ")(UBound(Split(RngNew.Text, " ")))
RngNew.Start = RngOld.End
Set RngOld = RngDoc.Duplicate
RngOld.Collapse wdCollapseEnd
With RngNew.Find
.ClearFormatting
.MatchWildcards = True
.Text = "[^13]" & StrTxt & "[!^13]{1,}[^13]"
With .Replacement
.ClearFormatting
.Text = "^&"
.Font.ColorIndex = wdRed
End With
.Wrap = wdFindStop
.Execute Replace:=wdReplaceOne
End With
RngDoc.Collapse wdCollapseEnd
Loop
End With
End With
Set RngDoc = Nothing: Set RngNew = Nothing: Set RngOld = Nothing
Application.ScreenUpdating = True
End Sub

[charliew001]

Thank you for your reply and the code Paul. I will try this out in the office tomorrow on my documents and provide feedback. So far everything seems to be working great though. Thank you!

[charliew001]

I have tried this out on all my docs and it is working great. Thank you