Création de clés de répartition en masse

Option Explicit
Sub essai()
Dim Cel As Range
Dim Matricules As Object, Roles As Object
Dim Lig As Long, Nbr As Long, I As Long, DerLig As Long, J As Long, K As Long, L As Long
Dim It, Tbl1, Tbl2
Dim LeRep As String, Ligne As String
Dim T As Single
T = Timer
Set Matricules = CreateObject("Scripting.Dictionary")
Set Roles = CreateObject("Scripting.Dictionary")
DerLig = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:B" & DerLig).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Header:=xlYes
For Each Cel In Range("A2:A" & DerLig)
    Matricules(Cel.Value) = Cel.Value
Next Cel
K = 1
For Each It In Matricules.Items
    L = 0
    Lig = Application.Match(It, Columns(1), 0)
    Nbr = Application.CountIf(Columns(1), It)
    For I = 1 To Nbr
        For J = 1 To Nbr
            If J <> I Then
                Roles(It & ";" & K) = Cells(Lig, 2).Offset(L).Value & ";" & Cells(Lig, 2).Offset(J - 1).Value
                K = K + 1
            End If
        Next J
        L = L + 1
    Next I
Next It
Tbl1 = Roles.Items
Tbl2 = Roles.keys
LeRep = ThisWorkbook.Path
Open LeRep & "\Concat.txt" For Output As #1
For I = 0 To Roles.Count - 1
    Ligne = ""
    Ligne = Ligne & Split(Tbl2(I), ";")(0) & ";" & Tbl1(I) & ";"
    Print #1, Left(Ligne, Len(Ligne) - 1)
Next I
Close #1
MsgBox Timer - T
End Sub

Option Explicit
Dim t1$(), t2$() 'mémorisation des tableaux

Sub Mémoriser()
Dim h&, t, lig&, k&, i&, j&, n&
[A:B].Sort [A1], , [B1], Header:=xlYes 'tri du tableau
h = Cells(Rows.Count, 1).End(xlUp).Row
t = [A1].Resize(h + 1, 2) 'matrice (plus rapide) avec ligne vide
For lig = 2 To h
  k = lig + 1
  While t(k, 1) = t(lig, 1): k = k + 1: Wend
  k = k - 1
  For i = lig To k
    For j = lig To k
      If i <> j Then
        ReDim Preserve t1(n): ReDim Preserve t2(n)
        t1(n) = t(i, 1): t2(n) = t(i, 2) & t(j, 2)
        n = n + 1
      End If
    Next j
  Next i
  lig = k
Next lig
If n = 0 Then Erase t1: Erase t2 'RAZ
ActiveSheet.Calculate
End Sub

Function Matricule()
Application.Volatile
Matricule = t1
End Function

Function Clé()
Application.Volatile
Clé = t2
End Function

Private Sub Workbook_Open()
Feuil1.Activate 'Codename
Mémoriser
Me.Saved = True
End Sub

Option Explicit
Dim t1$() 'mémorisation du tableau

Sub Mémoriser()
Dim h&, t, lig&, k&, i&, j&, n&
[A:B].Sort [A1], , [B1], Header:=xlYes 'tri du tableau
h = Cells(Rows.Count, 1).End(xlUp).Row
t = [A1].Resize(h + 1, 2) 'matrice (plus rapide) avec ligne vide
For lig = 2 To h
  k = lig + 1
  While t(k, 1) = t(lig, 1): k = k + 1: Wend
  k = k - 1
  For i = lig To k
    For j = lig To k
      If i <> j Then
        ReDim Preserve t1(1, n)
        t1(0, n) = t(i, 1): t1(1, n) = t(i, 2) & t(j, 2)
        n = n + 1
      End If
    Next j
  Next i
  lig = k
Next lig
If n = 0 Then Erase t1 'RAZ
ActiveSheet.Calculate
End Sub

Function RESULT()
Application.Volatile
RESULT = Application.Transpose(t1)
End Function