Remove Red macro

[netchie]

Hello,

I have a macro where it will remove all colors that are Red and any data of it and will not include the next different color and their data. The problem lately I'm noticing that the macro is also removing the next color after Red and some of its data. Can you please check what I've missed on this? Here is the print screen (I don't know how to upload the word file here) --> http://s14.postimage.org/olbv9g3up/Test.jpg . The ones in yellow shades should be removed but it should not include the next color (ex: Blue and its data) but for some reason the macro below is also removing them

 'Test Remove Red Color
Sub RemoveRed() 
    Application.ScreenUpdating = False 
    Dim i As Long, Rng As Range, sVpos As Single 
    With ActiveDocument.Range 
        With .Find 
            .ClearFormatting 
            .Replacement.ClearFormatting 
            .Text = "Red" 
            .Replacement.Text = "" 
            .Forward = True 
            .Wrap = wdFindStop 
            .Format = False 
            .MatchCase = False 
            .MatchWholeWord = False 
            .MatchWildcards = False 
            .MatchSoundsLike = False 
            .MatchAllWordForms = False 
            .Execute 
        End With 
        Do While .Find.Found 
            i = .Duplicate.Information(wdActiveEndPageNumber) 
            Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i) 
            Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page") 
            sVpos = 0 
            With Rng 
                For i = 1 To .Frames.Count 
                    If InStr(1, .Frames(i).Range.Text, "Red", vbTextCompare) Then 
                        .Frames(i).RelativeVerticalPosition = wdRelativeVerticalPositionPage 
                        sVpos = .Frames(i).VerticalPosition - 4 
                        Exit For 
                    End If 
                Next 
                For i = .Frames.Count To 1 Step -1 
                    With .Frames(i) 
                        If .VerticalPosition > (sVpos) Then 
                            If .VerticalPosition < (sVpos + 36) Then 
                                .Cut 
                            End If 
                        End If 
                    End With 
                Next 
            End With 
            .Collapse wdCollapseEnd 
            .Find.Execute 
        Loop 
    End With 
    Application.ScreenUpdating = True 
End Sub