Сочетания без повторений из разных числовых комбинаций, Нужно из определённой комбинации с различным числом чисел извлечь максимальное число сочетаний без повторений
Здравствуйте Уважаемые Форумчане! Нужна Ваша помощь, если можно и возможно, то это здорово. У меня Excel 2007. Нужен макрос Excel. Тема: Сочетания без повторений из разных числовых комбинаций
Нужно из определённой комбинации с различным числом чисел извлечь максимальное число сочетаний без повторений. Например, данна какая-то комбинация из 6(7-8-9-10 и т.д) чисел: 6 16 33 43 45 49 и я хочу применить(извлечь) максимальное число сочетаний без повторений То есть я использую по желанию формулу: 5 из 6 а это значит, что повторений будет максимально только 6, это зависит от комбинации. Количество чисел в комбинации могут быть различны и подбор может быть тоже разным. Например, комбинация из 6 чисел- 6 16 33 43 45 49 я могу применить 5 из 6, 4 из 6, 3 из 6 или 2 из 6. То есть найти сочетания из n по k. Комбинаций может быть большое количество.
Для перебора сочетания посмотрите реализацию здесь: http://www.excelworld.ru/forum/3-36449-1 Если не получится адаптировать к своей задаче - сообщите, можно будет применить макрос к текущей задаче Также можно сделать перебор 2^n комбинаций, что также будет полным аналогом, но в другой последовательности А лучше сообщите, какая конечная цель данного перебора, что будете дальше с ним делать?
Sub CalckC()
Dim a, b, i&, r&
r = 5: a = Split(Cells(r, 1)): Columns(2).ClearContents
For i = UBound(a) To 2 Step -1
b = CombinationsFromArray2M(a, i)
Cells(r, 2).Resize(UBound(b), 1) = WorksheetFunction.Transpose(b)
r = r + UBound(b) + 1
Next
End Sub
Function CombinationsFromArray2M(a, m As Long, Optional Sep$ = " ")
Dim p&(), r(), i&, j&, N&, di&, c&
di = 1 - LBound(a): N = UBound(a) + di
With WorksheetFunction: i = .Fact(N) / .Fact(m) / .Fact(N - m): End With
If Sep = "" Then ReDim r(1 To i, 1 To m) Else ReDim r(1 To i)
ReDim p(1 To m): For i = 1 To m: p(i) = i: Next: p(m) = p(m - 1)
Do
If p(m) < N Then
p(m) = p(m) + 1
Else
For i = m - 1 To 1 Step -1: If p(i) < N - m + i Then Exit For
Next
p(i) = p(i) + 1: For i = i + 1 To m: p(i) = p(i - 1) + 1: Next
End If
c = c + 1
If Sep = "" Then
For i = 1 To m: r(c, i) = a(p(i) - di): Next
Else
r(c) = a(p(1) - di): For i = 2 To m: r(c) = r(c) & Sep & a(p(i) - di): Next
End If
If c = UBound(r) Then Exit Do
Loop
CombinationsFromArray2M = r
End Function
выполните CalckC. если в А5 будет немного больше чисел - тоже сработает)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Игорь, большое Вам спасибо, Уважение и низкий поклон Вашему таланту. Как всегда, Вы на высоте! Вы сделали макрос с большим выбором чисел в комбинации! Это здорово!
да ладно... перебирать данные в массиве - это не высота, это задача для ремесленника от программирования, понимающего азы VBA если чисел в А5 будет много - макрос упадет по ошибке из-за выхода за размеры страницы грань между "много" и "не много" вы можете установить эмпирическим путем или посчитать (я обломился считать еще и это)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!