Macro rechercher plusieurs résultats

Je n'est pas mis tout le code car j'effectue d'autres actions. Voici le code complet :


Sub RechercheParEspècesExotiques()


Dim Mot As String
Dim Ws As Object
Dim Nbre As Long
Dim Cycle As Long
Dim Trouvé As Range
Dim CellAddress As Variant
Dim MyValue As String

'remets colonnes A-Q en blanc
Columns("A:Q").Select
With Selection.EntireRow.Columns("A:Q").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'remet colonnes A-Q ligne titre en gris
Range("A4:Q6").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249946592608417
.PatternTintAndShade = 0
End With

'Définition de la variable à rechercher
Mot = InputBox("Saisir l'espèce à chercher. ", Title:="Recherche Espèce")
'Vérification si existante
If Mot = "" Then Exit Sub
For Each Ws In Worksheets
Nbre = Nbre + Application.CountIf(Ws.UsedRange, "=" & Mot)
Next Ws
'Message en cas de mot inexistant
If Nbre = 0 Then
MyValue = MsgBox(" L'espèce " & Mot & " n'est pas enregistrée ", vbOKOnly, " Recherche Espèce ")
Else
Cycle = 0
'Recherche et arrêt sur les cellules contenant le Mot
For Each Ws In Worksheets
With ActiveSheet
.Activate
Set Trouvé = Ws.Columns(2).Find(Mot, , xlValues, xlWhole)
If Not Trouvé Is Nothing Then
CellAddress = Trouvé.Address
Do
Ws.Activate
Trouvé.Select
MyValue = MsgBox(" L'espèce " & Mot & " a été trouvée ", vbOKOnly, " Recherche Espèce ")
'colorier la case du résultat en vert
With Selection.EntireRow.Columns("A:Q").Interior
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Exit Sub

If MyValue = vbNo Then Exit For
Set Trouvé = Ws.Columns(2).FindNext(After:=Trouvé)

Loop While Not Trouvé Is Nothing And Trouvé.Address <> CellAddress

End If

End With
Next Ws
End If

End Sub

Le code a été fait par moi j'ai essayer avec activesheets sans résultats.