Vba

Sub Test()
Dim C As Range
Dim firstAddress As String
    Set C = Worksheets("Feuil1").Columns(1).Find("pneu", , xlValues, xlWhole)
    If Not C Is Nothing Then
        firstAddress = C.Address
        Do
            If C.Font.Bold = False Then
                Worksheets("Feuil2").Range("B3") = C.Offset(, 2).Value
                Exit Do
            End If
            Set C = Worksheets("Feuil1").Columns(1).FindNext(C)
        Loop While Not C Is Nothing And C.Address <> firstAddress
    End If
End Sub

Option Explicit
'-----------------------------
Sub chercher_pneugras()
Dim zone As Range, cellule As Range
Dim Cptr As Integer

Application.ScreenUpdating = False
Set zone = Sheets(1).Range("A1:C10")
With zone
    If Application.CountIf(zone, "pneu") = 0 Then GoTo vide
    Set cellule = .Find(what:="pneu", LookIn:=xlValues)
    For Cptr = 1 To 2
            If cellule.Font.Bold = True Then
                Sheets(2).Range("B3") = Sheets(1).Cells(cellule.Row, "C")
                Exit For
            End If
            Set cellule = .FindNext(cellule)
    Next
End With
Exit Sub

vide:
MsgBox """pneu"" absent dans la zone!", vbExclamation
End Sub