Sub aaa()
Call bbb(15)
End Sub
Sub bbb(ByVal n&)
Dim a%(), i%, j%, k%, b%, t, d As Object, x$, t1
If n < 2 Then Exit Sub
ReDim a(1 To n + 1, 1 To n, 1 To n)
For i = 1 To n: For j = 1 To n: a(1, i, j) = n * (i - 1) + j: a(2, i, j) = n * (j - 1) + i: Next j, i
For k = 3 To n + 1: For i = 1 To n: For j = 1 To n: b = i + (j - 1): b = b + n * (b > n): a(k, i, j) = a(k - 1, b, j): Next j, i, k
Sheets.Add
For k = 1 To n + 1: Cells((k - 1) * n + 1, 1) = "Tour " & k: For i = 1 To n: For j = 1 To n: Cells((k - 1) * n + i, j + 1) = a(k, i, j): Next j, i, k
Cells.EntireColumn.AutoFit
'---vérification---
t = Cells(1, 2).Resize(n * (n + 1), n)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t): For j = 1 To n - 1: For k = j + 1 To n: x = t(i, j) & " " & t(i, k): d(x) = d(x) + 1: Next k, j, i
MsgBox "Nombre de paires uniques créées : " & d.Count & " sur " & n * n * (n * n - 1) / 2 & " "
If d.Count = n * n * (n * n - 1) / 2 Then Exit Sub
'---analyse des doublons---
t = d.items: d.RemoveAll
For n = 0 To UBound(t): d(t(n)) = d(t(n)) + 1: Next
t = d.keys: t1 = d.items: x = ""
For n = 0 To UBound(t): x = x & vbLf & t1(n) & " paires sont créées " & t(n) & " fois": Next
MsgBox Mid(x, 2), , "Analyse"
End Sub