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 fff3() Dim N&, n1&, i&, k&, i1&, i2&, k1& Dim M&(), m1&(), P$() Dim o As Object, key1 As String, key2 As String Set o = CreateObject("Scripting.Dictionary") Set rng = Application.InputBox("Укажите ячейки множества M", "Множество", Type:=8) N = rng.Rows.Count cl& = rng.Column rw& = rng.Rows(1).Row 'N = 5 n1 = 3 ReDim M(N) For i = 1 To N M(i) = Cells(rw + i - 1, cl) Next i k = f(N) / f(2) / f(N - 2) ' задуманно, что в P пары из мн-ва M ReDim P(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(k1) = M(i) & "-" & M(i1) o.Add key1, k1 o.Add key2, k1 End If End If Next i1 Next i For i = 1 To k1 Cells(rw + i - 1, cl + 1).NumberFormat = "@" Cells(rw + i - 1, cl + 1) = P(i) Next i End Sub
[/vba] Вообще, честно, трудно пока понять как сделать под разное число символов, из которых должны состоять группы в множестве m. Но конкретно для 3х, вродебы понятно как делать... [p.s.]как говориться, поспешишь... Исправил 1й этап[/p.s.]
VLD, Первая часть выглядит так: [vba]
Код
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 fff3() Dim N&, n1&, i&, k&, i1&, i2&, k1& Dim M&(), m1&(), P$() Dim o As Object, key1 As String, key2 As String Set o = CreateObject("Scripting.Dictionary") Set rng = Application.InputBox("Укажите ячейки множества M", "Множество", Type:=8) N = rng.Rows.Count cl& = rng.Column rw& = rng.Rows(1).Row 'N = 5 n1 = 3 ReDim M(N) For i = 1 To N M(i) = Cells(rw + i - 1, cl) Next i k = f(N) / f(2) / f(N - 2) ' задуманно, что в P пары из мн-ва M ReDim P(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(k1) = M(i) & "-" & M(i1) o.Add key1, k1 o.Add key2, k1 End If End If Next i1 Next i For i = 1 To k1 Cells(rw + i - 1, cl + 1).NumberFormat = "@" Cells(rw + i - 1, cl + 1) = P(i) Next i End Sub
[/vba] Вообще, честно, трудно пока понять как сделать под разное число символов, из которых должны состоять группы в множестве m. Но конкретно для 3х, вродебы понятно как делать... [p.s.]как говориться, поспешишь... Исправил 1й этап[/p.s.]Roman777
Много чего не знаю!!!!
Сообщение отредактировал Roman777 - Вторник, 28.06.2016, 21:06
Gustav, да, запускал, просто изначально не под пример делал... а просто в массивах... Потом времени уже было немного переделать... вот и накосячил... Вот такое было... но надо переделать чуть-чуть...
[vba]
Код
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
[/vba]
Делал для конкретного случая с кол-вом элементов множеств m равным 3... для произвольного пока мне думки не хватает... я и эту то версию полностью нормально не потестил... Поэтому и взял отсюда только первую часть. [p.s.]6е сообщение поправил.[/p.s.] Исправил парочку (из некоторых) глупостей:
[vba]
Код
'можно и без ф-ии факториала 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
[/vba]
Gustav, да, запускал, просто изначально не под пример делал... а просто в массивах... Потом времени уже было немного переделать... вот и накосячил... Вот такое было... но надо переделать чуть-чуть...
[vba]
Код
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
[/vba]
Делал для конкретного случая с кол-вом элементов множеств m равным 3... для произвольного пока мне думки не хватает... я и эту то версию полностью нормально не потестил... Поэтому и взял отсюда только первую часть. [p.s.]6е сообщение поправил.[/p.s.] Исправил парочку (из некоторых) глупостей:
[vba]
Код
'можно и без ф-ии факториала 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
В кой-то веке дошел до задачки. Меня заинтересовала. Сделал, как вариант. Мб создаёт и не самое минимальное кол-во множеств "m", но определённые "стремления" к этому в алгоритме существуют. На относительно небольших (насколько небольших точно сказать не могу) множествах "М" и "m", работает, вродебы, хорошо.
[vba]
Код
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
[/vba]
В файле пример на 2м листе.
В кой-то веке дошел до задачки. Меня заинтересовала. Сделал, как вариант. Мб создаёт и не самое минимальное кол-во множеств "m", но определённые "стремления" к этому в алгоритме существуют. На относительно небольших (насколько небольших точно сказать не могу) множествах "М" и "m", работает, вродебы, хорошо.
[vba]
Код
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