Find and Replace

[Bikram]

Greeting to all, I wrote the following code to find and replace multiple fonts but it is not working

Sub Macro39()

 Dim i As Integer
 Dim fta()
 
    fta = Array("Book Antiqua", "Arial Narrow","Arial")
        For i = 0 To UBound(fta)
            With Selection.find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Font.Bold = True
                .Font.Name = fta(i)
            End With
            With Selection.find
                .Text = ""
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindStop
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
                Do While Selection.find.Execute = True
                    Select Case Selection.Range.Style
                    Case "tt"
                        Selection.Range.Select
                            With Selection
                                .Font.Name = "Lato Heavy"
                                .Font.Size = 7.5
                                .Font.Bold = False
                                .MoveRight unit:=wdWord, Count:=1
                            End With
                    Case "aq", "b"
                        With Selection
                            .Font.Name = "Arial"
                            .Font.Size = 7.5
                            .Font.Bold = False
                            .MoveRight unit:=wdWord, Count:=1
                      End With
                    End Select
                Loop
        Next
End Sub

It works but only for the first item in the array. Can someone point out why is it not working as expected? Thanks in advance.