Function f(ByVal i_n As Integer) As Long
Dim i&
f = 1
For i = 1 To i_n
f = f * i
Next i
End Function

Sub fff2()
Dim N&, n1&, i&, k&, i1&, i2&, k1&, k2&
Dim M&(), m1&(), P$(), p1$()
Dim o As Object, key1 As String, key2 As String
Dim FLG As Boolean
Set o = CreateObject("Scripting.Dictionary")
N = 5
n1 = 3
ReDim M(N)
For i = 1 To N
  M(i) = i
Next i
k = f(N) / f(2) / f(N - 2)
' задуманно, что в P пары из мн-ва M
ReDim P(2, k)
For i = 1 To N
  For i1 = 1 To N
     If M(i) <> M(i1) Then
        key1 = M(i) & M(i1)
        key2 = M(i1) & M(i)
        If Not (o.exists(key1) And o.exists(key2)) Then
           k1 = k1 + 1
           P(1, k1) = M(i)
           P(2, k1) = M(i1)
           o.Add key1, k1
           o.Add key2, k1
        End If
     End If
  Next i1
Next i
'конец первой части (записаны все возможные пары)
o.RemoveAll
k = 0
k1 = UBound(P, 2)
ReDim p1(3, 1)
For i = 1 To k1
  If k1 = k2 Then
     Exit Sub
  End If
  key1 = P(1, i) & P(2, i)
  If Not o.exists(key1) Then
     o.Add key1, key1
     p1(1, k + 1) = P(1, i)
     p1(2, k + 1) = P(2, i)
     FLG = False
     For i1 = 1 To k1
        If P(2, i) = P(1, i1) Then
          key2 = P(1, i1) & P(2, i1)
          If Not o.exists(key2) Then
             o.Add key2, key2
             k = k + 1
             k2 = k2 + 1
             If Not P(1, i) & P(2, i1) Then
                o.Add P(1, i) & P(2, i1), P(1, i) & P(2, i1)
                k2 = k2 + 1
             End If
             ReDim Preserve p1(3, k + 1)
             p1(3, k) = P(2, i1)
             FLG = True
             Exit For
          Else
             If Not FLG Then
                k = k + 1
                If Not P(1, i) & P(2, i1) Then
                   o.Add P(1, i) & P(2, i1), P(1, i) & P(2, i1)
                   k2 = k2 + 1
                End If
                ReDim Preserve p1(3, k + 1)
                p1(3, k) = P(2, i1)
             End If
          End If
        End If
     Next i1
  End If
Next i
For i = 1 To 3
  For i1 = 1 To UBound(p1, 2)
     Cells(i1, i) = p1(i, i1)
  Next i1
Next i
End Sub

'можно и без ф-ии факториала
Sub fff2_()
Dim N&, n1&, i&, k&, i1&, i2&, k1&, k2&
Dim M&(), m1&(), P$(), p1$()
Dim o As Object, key1 As String, key2 As String
Dim FLG As Boolean
Set o = CreateObject("Scripting.Dictionary")
N = 5  'количество элементов 1,2,3 ... множества M
n1 = 3
ReDim M(N)
ReDim m1(n1)
For i = 1 To N
M(i) = i
Next i
k = (N - 1) * N / 2 'факториалы упростились
For i = 1 To n1
m1(i) = i
Next i
ReDim P(2, k)
For i = 1 To N
For i1 = 1 To N
    If M(i) <> M(i1) Then
        key1 = M(i) & "-" & M(i1)
        key2 = M(i1) & "-" & M(i)
        If Not (o.exists(key1) And o.exists(key2)) Then
        k1 = k1 + 1
        P(1, k1) = M(i)
        P(2, k1) = M(i1)
        o.Add key1, k1
        o.Add key2, k1
        End If
    End If
Next i1
Next i
o.RemoveAll
k = 0
k1 = UBound(P, 2)
ReDim p1(3, 1)
For i = 1 To k1
If k1 = k2 Then
    Exit Sub
End If
key1 = P(1, i) & P(2, i)
If Not o.exists(key1) And P(2, i) <> M(UBound(M)) Then
'для данной задачи пока не ясно, можно ли создавать множество аля "1-10-2-5-3"
    k = k + 1
    ReDim Preserve p1(3, k)
    o.Add key1, ""
    p1(1, k) = P(1, i)
    p1(2, k) = P(2, i)
    FLG = False
    For i1 = 1 To k1
        If P(2, i) = P(1, i1) Then
        key2 = P(1, i1) & P(2, i1)
        If Not o.exists(key2) Then
            o.Add key2, ""
            k2 = k2 + 1
            If Not P(1, i) & P(2, i1) Then
                o.Add P(1, i) & P(2, i1), ""
                k2 = k2 + 1
            End If
            p1(3, k) = P(2, i1)
            FLG = True
            Exit For
        Else
            If Not FLG Then
                If Not P(1, i) & P(2, i1) Then
                o.Add P(1, i) & P(2, i1), ""
                k2 = k2 + 1
                End If
                p1(3, k) = P(2, i1)
            End If
        End If
        End If
    Next i1
End If
Next i
For i = 1 To 3
For i1 = 1 To UBound(p1, 2)
    Cells(i1, i) = p1(i, i1)
Next i1
Next i
End Sub

Sub F_pod_file_()
' крайний + добавлен подсчет использованности
Dim N&, n1&, i&, i1&, i2&, k&, k1&, k2&, Km&, j&, km1&, r1&, c1&
Dim M&(), Mrng As Range, r As Range, P&(), p1$(), pp&, Pm&(), S&, Pi&
Dim o As Object, key1 As String, key2 As String, key3 As String
Dim o1 As Object, o2 As Object
r1 = Cells(Rows.Count, 2).End(xlUp).Row                'ищем количество строк в рабочем диапазоне
c1 = Cells(2, Columns.Count).End(xlToLeft).Column      'ищем количество столбцов в рабочем диапазоне
Set o = CreateObject("Scripting.Dictionary")
Set o1 = CreateObject("Scripting.Dictionary") ' будем записывать в него текущее положение пары в массиве
Set o2 = CreateObject("Scripting.Dictionary") 'будем записывать в него все числа текущего множества m
'N = 3 'количество элементов 1,2,3 ... множества M
Set Mrng = Application.InputBox("Выбирите ячейки массива ""M""", "Массив ""М""", Type:=8)
N = Mrng.Cells.Count
n1 = Cells(2, 3) ' количество чисел в множестве m
pp = 2 ' показывает что изначально в множестве M выбираются пары и по ним создаём множества m
ReDim M(N)
Km = N ^ pp - N
ReDim Pm(pp + 1, Km) ' в данный массив заносим все пары с учётом, что 1-2 и 2-1 - разные пары (по нему основной счет)
For Each r In Mrng
i = i + 1
M(i) = r
Next r
k = (N - 1) * N / 2 'факториалы|упростились количество пар в множестве M
km1 = (n1 - 1) * n1 / 2 'количество пар в каждом множестве m
ReDim P(pp + 1, k) ' в данный массив заносим все пары с учётом, что 1-2 и 2-1 - одно и то же
k = 0
For i = 1 To N
  For i1 = 1 To N
    If M(i) <> M(i1) Then
        k1 = k1 + 1
        Pm(1, k1) = M(i)
        Pm(2, k1) = M(i1)
        key1 = M(i) & "-" & M(i1)
        key2 = M(i1) & "-" & M(i)
        If Not (o.exists(key1) And o.exists(key2)) Then
        k = k + 1
        P(1, k) = M(i)
        P(2, k) = M(i1)
        o.Add key1, k
        o.Add key2, k
        End If
        o1.Add M(i) & "-" & M(i1), k1
    End If
  Next i1
Next i
' k  - количество пар
k1 = 0
o.RemoveAll
ReDim p1(n1 + km1, 1)
For i = 1 To Km
  key1 = Pm(1, i) & "-" & Pm(2, i)
  key2 = Pm(2, i) & "-" & Pm(1, i)
  o2.RemoveAll ' с новой "строки" обновляем массив цифр в множестве m
  If Not o.exists(key1) Then
     k2 = k2 + 2
     Pm(3, o1(key1)) = Pm(3, o1(key1)) + 1
     Pm(3, o1(key2)) = Pm(3, o1(key3)) + 1
     k1 = k1 + 1
     ReDim Preserve p1(n1 + km1, k1)
     p1(1, k1) = Pm(1, i)
     p1(2, k1) = Pm(2, i)
     o.Add key1, 1
     o.Add key2, 1
     o2.Add Pm(1, i), ""
     o2.Add Pm(2, i), ""
     For i1 = pp + 1 To n1
        ' ищем первую пару, совпадающую по первому члену, но наименее часто используемую
        S = Km
        For i2 = 1 To Km
           If p1(i1 - 1, k1) = Pm(1, i2) Then
              If S > Pm(3, i2) And Not o2.exists(Pm(2, i2)) Then
                 S = Pm(3, i2)
                 Pi = i2
              End If
           End If
        Next i2
        p1(i1, k1) = Pm(2, Pi)
        o2.Add Pm(2, Pi), ""
        'далее суммируем все смежные получившиеся пары в множестве m
        For j = 1 To i1 - 1
           key1 = p1(j, k1) & "-" & p1(i1, k1)
           key2 = p1(i1, k1) & "-" & p1(j, k1)
           If Not o.exists(key1) Then
              k2 = k2 + 2
              o.Add key1, 1
              o.Add key2, 1
           Else
              o.Item(key1) = o.Item(key1) + 1
              o.Item(key2) = o.Item(key2) + 1
           End If
        'суммируем используемую пару (и соотвественно "антипару")
           Pm(3, o1(key1)) = Pm(3, o1(key1)) + 1
           Pm(3, o1(key2)) = Pm(3, o1(key2)) + 1
        Next j
     Next i1
  End If
  If k2 >= Km Then
     Exit For
  End If
Next i
'ПРИЧЕСЫВАНИЕ ПОЛУЧЕННЫХ РЕЗУЛЬТАТОВ
Union(Cells(1, 5).Resize(r1, c1), Cells(2, 2).Resize(r1)).ClearContents
Cells(1, 5).Resize(, c1).MergeCells = False
Cells(1, 1) = "Множество M"
Cells(1, 2) = "Все пары множества М"
Cells(1, 5).Resize(, n1).Merge
Cells(1, 5) = "сами множества m"
Cells(1, 7 + n1).Resize(, km1).Merge
Cells(1, 7 + n1) = "пары в m"
Cells(1, 8 + n1 + km1) = "Все пары"
Cells(1, 9 + n1 + km1) = "Количество пар во множествах m"
'_____сортировка слева на право по возрастанию + заполнение массива p1 парами мн-в m
For i = 1 To UBound(p1, 2)
   For j = 2 To n1
      If CInt(p1(j, i)) < CInt(p1(j - 1, i)) Then
         S = p1(j, i)
         p1(j, i) = p1(j - 1, i)
         p1(j - 1, i) = S
         j = 1
      End If
   Next j
   o1.RemoveAll
   k = 0
   For j = 1 To n1
      For i1 = 1 To n1
         If p1(j, i) <> p1(i1, i) Then
            key1 = p1(j, i) & "-" & p1(i1, i)
            If Not o1.exists(key1) Then
               k = k + 1
               o1.Add key1, ""
               o1.Add p1(i1, i) & "-" & p1(j, i), ""
               p1(n1 + k, i) = key1 '__________________ заполняю в массив пары мн-ва m
            End If
         End If
      Next i1
   Next j
Next i
'_____сортировка слева на право по возрастанию
For i = 1 To UBound(P, 2)
   Cells(i + 1, 2).NumberFormat = "@"
   Cells(i + 1, 2) = P(1, i) & "-" & P(2, i)
   Cells(i + 1, n1 + km1 + 8).NumberFormat = "@"
   Cells(i + 1, n1 + km1 + 8) = P(1, i) & "-" & P(2, i)
   Cells(i + 1, n1 + km1 + 9).NumberFormat = "General"
   Cells(i + 1, n1 + km1 + 9) = o(P(1, i) & "-" & P(2, i))
Next i
For i = 1 To UBound(p1, 2)
   For j = 1 To UBound(p1)
     If j <= n1 Then
        Cells(i + 1, j + 4).NumberFormat = "General"
        Cells(i + 1, j + 4) = p1(j, i)
     Else
        Cells(i + 1, j + 6).NumberFormat = "@"
        Cells(i + 1, j + 6) = p1(j, i)
     End If
   Next j
Next i
End Sub