XL 2016 Extraire plusieurs données d'une même cellule

Sub Extraction_90AA()
Const max = 15000
Dim derlig&, deb&, ncol&, n&, i&, j&, nfois, x, t, res(), T0

T0 = Timer
Application.ScreenUpdating = False
With Sheets("Feuil1")
   If .FilterMode Then .ShowAllData
   derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
   deb = 1
   Do
      nfois = nfois + 1: t = .Cells(deb, "a").Resize(max)
      ReDim res(1 To max, 1 To 1)
      For i = 1 To UBound(t)
         j = 1: n = 0: x = t(i, 1)
         If x <> "" Then
            Do
               j = InStr(j, x, "90AA", vbTextCompare)
               If j > 0 Then
                  n = n + 1
                  If n > UBound(res, 2) Then ReDim Preserve res(1 To UBound(res), 1 To UBound(res, 2) + 1)
                  res(i, n) = Mid(x, j, 14)
                  j = j + 10
               Else
                  Exit Do
               End If
            Loop
         End If
      Next i
      With Sheets("Extract")
         If nfois = 1 Then .Range("a1").CurrentRegion.Clear
         .Range("a1").Offset(max * (nfois - 1)).Resize(max, UBound(res, 2)) = res
         .Range("a1").CurrentRegion.EntireColumn.AutoFit
      End With
      If max * nfois >= derlig Then Exit Do
   Loop
End With
MsgBox "Durée: " & Format(Timer - T0, "0.00\ sec.")
End Sub

Function Extract$(txt$, critere$, n%, ordre%)
Dim s
s = Split(txt, critere)
If ordre <= UBound(s) Then Extract = critere & Left(s(ordre), n)
End Function

Sub Test()
Dim t
t = Timer
[A2:F2].AutoFill [A2:F100001]
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Sub Extraire()
Dim t, critere$, n%, tablo, nlig&, i&, s, ub%, ubmax%, resu(), j%
t = Timer
critere = "90AA" 'à adapter
n = 10 'à adapter
tablo = [A1].CurrentRegion.Columns(1) 'matrice, plus rapide
If Not IsArray(tablo) Then Exit Sub 'si tableau vide
nlig = UBound(tablo)
'---tableau des résultats---
For i = 2 To nlig
    s = Split(tablo(i, 1), critere)
    ub = UBound(s)
    If ub > ubmax Then ubmax = ub: ReDim Preserve resu(1 To nlig, 1 To ub)
    For j = 1 To ub
        resu(i, j) = critere & Left(s(j), n)
Next j, i
'---restitution---
With Feuil1 'CodeName de la feuille de restitution, à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[B1] 'adaptable
        If ubmax Then
            .Resize(nlig, ubmax) = resu
            .Value = "Extract " & 1: .Cells.AutoFill .Resize(, ubmax)
        End If
        .Offset(, ubmax).Resize(, .Parent.Columns.Count - ubmax - .Column + 1).EntireColumn.ClearContents 'RAZ à droite
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Sub Extraire()
Dim t, critere$, n%, tablo, nlig&, i&, s, ub%, ubmax%, resu(), j%
t = Timer
critere = "90AA" 'à adapter
n = 10 'à adapter
tablo = [A1].CurrentRegion.Columns(1) 'matrice, plus rapide
If Not IsArray(tablo) Then GoTo 1 'si tableau vide
nlig = UBound(tablo)
'---tableau des résultats---
For i = 2 To nlig
    s = Split(tablo(i, 1), critere)
    ub = UBound(s)
    If ub > ubmax Then ubmax = ub: ReDim Preserve resu(1 To nlig, 1 To ub)
    For j = 1 To ub
        resu(i, j) = critere & Left(s(j), n)
Next j, i
'---restitution---
1 With Sheets("Extraction") 'feuille de restitution, à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1] 'adaptable
        If nlig Then .Resize(nlig) = tablo
        If ubmax Then
            With .Cells(1, 2)
                .Resize(nlig, ubmax) = resu
                .Value = "Extract " & 1: .Cells.AutoFill .Resize(, ubmax)
                .Resize(, ubmax).EntireColumn.AutoFit 'ajustement largeur
            End With
        End If
        .Offset(, ubmax + 1).Resize(, .Parent.Columns.Count - ubmax - .Column).EntireColumn.Delete 'RAZ à droite
        .Offset(nlig).Resize(.Parent.Rows.Count - nlig - .Row + 1).EntireRow.Delete 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub