XL 2016 Extraire plusieurs chaînes de caractères d'une même cellule

Sub ImportFm()

  With ActiveSheet
    ChargerLaListeDesFM .Range("A2:A800")
  End With

End Sub


Sub ChargerLaListeDesFM(ByVal AireFM As Range)

Dim I As Integer, J As Integer, K As Integer
Dim ListeFm As Object
Dim Fm As String
Dim ListeCles As Variant, TabFm As Variant, Temp1 As Variant

    Range(AireFM.Offset(0, 1), AireFM.Offset(0, 9)).ClearContents

    For K = 1 To AireFM.Count
          
        TabFm = Split(AireFM(K), "FM")
        Temp1 = ""
        Set ListeFm = CreateObject("Scripting.Dictionary")

        For I = LBound(TabFm) To UBound(TabFm)
            Select Case Mid(TabFm(I), 1, 1)
                   Case 0 To 9
                        Fm = "FM" & Mid(TabFm(I), 1, 5)
                        If Not ListeFm.Exists(Fm) Then ListeFm.Add Fm, Fm
            End Select
        Next I
            
        ListeCles = ListeFm.keys
                      
        ' Tri des FM par ordre alphabétique
        '----------------------------------
        For I = LBound(ListeCles) To UBound(ListeCles) - 1
                For J = I + 1 To UBound(ListeCles)
                    If ListeCles(I) > ListeCles(J) Then
                       Temp1 = ListeCles(I)
                       ListeCles(I) = ListeCles(J)
                       ListeCles(J) = Temp1
                     End If
                Next J
        Next I
          
        ' Mise à jour du tableau
        '-----------------------
        For I = LBound(ListeCles) To UBound(ListeCles)
            If ListeCles(I) <> "" Then AireFM(K).Offset(0, I + 1) = ListeCles(I)
        Next I
        
        Erase ListeCles
        Set ListeFm = Nothing
            
    Next K
    
    Set ListeFm = Nothing

End Sub

Function niemeFM$(ByVal x$, rang&)
Dim s, n&, num, i&, suff, c$, nombre As Boolean
   s = Split("/" & x, "FM")
   For Each num In s
      nombre = False: suff = ""
      For i = 1 To Len(num)
         c = Mid(num, i, 1)
         If c Like "#" Then
            nombre = True
            suff = suff & c
         Else
            Exit For
         End If
      Next i
      If nombre Then n = n + 1: If n = rang Then niemeFM = "FM" & suff: Exit Function
   Next num
End Function

Function GetChaineFM(cel As String)
     Dim t$(), I&, A&
    I = InStr(1, cel, "FM")
    Do Until I = 0
        cx = Mid(cel, I, Len(cel)) 'on coupe à "FM"
        cx = Mid(cx, 1, InStr(1, cx, " ")) 'on coupe au premier espaced de la coupe précédente
        A = A + 1: ReDim Preserve t(1 To A): t(A) = cx 'on stock
        I = InStr(I + 1, cel, "FM") 'on avance le i de 1 pour passer ausuivant
    Loop
      ReDim Preserve t(1 To Application.Caller.Columns.Count) 'on redimpreserve au nombre de cellules ayant la formule en matricielle
    GetChaineFM = t
End Function

Function GetChaineFM(cel As String, Optional MatricalCell As Boolean = True)
     Dim t$(), I&, A&
    I = InStr(1, cel, "FM")
    Do Until I = 0
        cx = Mid(cel, I, Len(cel)) 'on coupe à "FM"
        cx = Mid(cx, 1, InStr(1, cx, " ")) 'on coupe au premier espaced de la coupe précédente
       If Not " " & Join(t, " ") & " " Like "*" & cx & "*" Then A = A + 1: ReDim Preserve t(1 To A): t(A) = cx 'on stock
        I = InStr(I + 1, cel, "FM") 'on avance le i de 1 pour passer ausuivant
    Loop
      ReDim Preserve t(1 To Application.Caller.Columns.Count) 'on redimpreserve au nombre de cellules ayant la formule en matricielle
    GetChaineFM = t
End Function