XL 2013 code vba pour remplissage automatique

=SUPPRESPACE(DROITE(SUBSTITUE(A2;" ";REPT(" ";255));255))

Function Extract$(x$, matrice)
Dim s, ub%, i%
s = Split(Application.Trim(x))
ub = UBound(s)
For i = 0 To ub
    If IsNumeric(Application.Match(s(i), matrice, 0)) Then
        If i < ub Then Extract = s(i + 1)
        Exit For
    End If
Next
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, matrice, i&, tablo, resu(), s, ub%, j%
'---mémorisation---
Set d = CreateObject("Scripting.Dictionary")
matrice = Array("FAV.", "VERS", "CB") 'modifiable
For i = 0 To UBound(matrice): d(matrice(i)) = "": Next i
'---tableau des résultats---
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(tablo), 1 To 1)
For i = 2 To UBound(tablo)
    s = Split(Application.Trim(tablo(i, 1)))
    ub = UBound(s)
    For j = 0 To ub
        If d.exists(s(j)) Then
            If j < ub Then resu(i, 1) = s(j + 1)
            Exit For
        End If
Next j, i
'---restitution---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [C1] '1ère cellule de destination
    resu(1, 1) = .Value
    .Resize(i - 1) = resu
    .Offset(i - 1).Resize(Rows.Count - i - .Row + 2).ClearContents  'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub