Sub Demo()
Dim arrFnd, arrRep, i As Long, j As Long
arrFnd = Array("Air Boat", "Power Boat", "Ferry")
arrRep = Array("AB123", "PB456", "F123")
For i = 0 To UBound(arrFnd)
  j = 0
  With ActiveDocument.Range
    With .Find
      .Text = arrFnd(i)
      .MatchWholeWord = True
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      j = j + 1
      If j = 2 Then
        .InsertAfter arrRep(i)
        Exit Do
      End If
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next i
End Sub