Microsoft 365 Table de correspondance/mapping à partir d'une partie de mot

Sub Macro1()
Dim OM As Worksheet
Dim TM As Variant
Dim ORA
Dim TORA As Variant
Dim TL() As Variant
Dim I As Integer
Dim J As Integer
Dim K As Integer

Set OM = Worksheets("Feuil2")
TM = OM.Range("A1").CurrentRegion
Set ORA = Worksheets("Feuil1")
TORA = ORA.Range("A1").CurrentRegion
For I = 1 To UBound(TORA, 1)
    For J = 1 To UBound(TM, 1)
        If InStr(1, TORA(I, 1), TM(J, 1), vbTextCompare) <> 0 Then
            K = K + 1
            ReDim Preserve TL(1 To K)
            TL(K) = TM(J, 2)
            Exit For
        End If
    Next J
Next I
ORA.Range("B1").Resize(K, 1).Value = Application.Transpose(TL)
End Sub