XL 2016 Trie d'information dans des cellules

Dim feuille, col As Variant, nlig&, resu(), tablo, i&, nom$, s, ub%, j%, n&, x$, p%
feuille = Array("ID", "PRO") 'liste des feuilles, à adapter
col = Application.Match(Sh.Name, feuille, 0)
If IsError(col) Then Exit Sub
col = col + 1

Sub Ind_Base_Titre()
Dim d As Object, tablo, i&, s, j%, txt$, p%, x$, y$, z$
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Base")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    tablo = .Range("E1:F" & .Range("E" & .Rows.Count).End(xlUp).Row) 'matrice, plus rapide, au moins 2 éléments
    For i = 2 To UBound(tablo)
        s = Split(tablo(i, 1), ",")
        For j = 0 To UBound(s)
            txt = s(j)
            If txt Like "ACR*/*" Then
                p = InStr(txt, "/")
                x = Left(txt, p - 1)
                If Not d.exists(x) Then
                    y = Mid(txt, p + 1)
                    p = InStr(y, ";")
                    z = ""
                    If p Then z = Mid(y, p + 1): y = Left(y, p - 1)
                    d(x) = y & Chr(1) & z 'mémorise la chaîne
                End If
            End If
    Next j, i
End With
With Sheets("ACR")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .Range("B1:D" & .Range("B" & .Rows.Count).End(xlUp).Row) 'matrice, plus rapide
        tablo = .Value
        For i = 2 To UBound(tablo)
            x = tablo(i, 1)
            If d.exists(x) Then
                s = Split(d(x), Chr(1)) 'récupère la chaîne
                tablo(i, 2) = s(0)
                tablo(i, 3) = s(1)
            Else
                tablo(i, 2) = ""
                tablo(i, 3) = ""
            End If
        Next i
        .Value = tablo 'restitution
    End With
End With
End Sub