Sub Inscrire()
Dim P1 As Range, P2 As Range, col%, Ncol%, cel As Range
Dim n&, c1 As Range, c2 As Range, t As Boolean
Set P1 = [O5:R8]
Set P2 = [B5:F65536]
col = P2.Column - 1 'colonne du n° de série
Ncol = P2.Columns.Count
P1.ClearContents
For Each cel In P1
n = n + 1
Set c1 = P2.Find(n, P2(P2.Rows.Count, Ncol), xlValues, xlWhole)
If Not c1 Is Nothing Then
Set c2 = P2.Find(n, c1)
t = c2.Address <> c1.Address
cel = c1(1, Ncol + 2) & IIf(t, " - " & c2(1, Ncol + 2), "") & vbLf _
& Cells(c1.Row, col) & IIf(t, " - " & Cells(c2.Row, col), "")
With cel.Characters(InStr(cel, vbLf)).Font
.Size = 14
.Bold = True
End With
End If
Next
End Sub