Есть массив чисел 1, 2, 3....16, из них нужно сначала выбрать все возможные сочетания по 5 (их будет в сумме 4368) Вопрос был практически решен здесь http://www.excelworld.ru/forum/2-1805-1 Огромное спасибо, МСН !!! - Только может кто-нибудь мог бы подсказать как можно вместо цветов выбрать числа?
А после этого нужно собрать из них набор комбинаций такой, чтобы у любых двух из них было не более 2 общих номеров между собой. Например.. 1 2 3 4 5 1 2 6 7 8 3 4 6 7 9 и т.д. Я так понимаю, такой набор можно выбрать многими разными способами, но мне достаточно одного, любого. Наверное, нужно задать какую-то формулу с оператором "если", которая будет по очереди прогонять все сочетания и сравнивать их с предыдущими "положительно" отобранными; если с каждым из них не более 2 общих чисел - добавлять эту комбинацию тоже в "положительный" список. Вопрос только в том, как задать это условие - "не более 2"?
Добрый день!
Есть массив чисел 1, 2, 3....16, из них нужно сначала выбрать все возможные сочетания по 5 (их будет в сумме 4368) Вопрос был практически решен здесь http://www.excelworld.ru/forum/2-1805-1 Огромное спасибо, МСН !!! - Только может кто-нибудь мог бы подсказать как можно вместо цветов выбрать числа?
А после этого нужно собрать из них набор комбинаций такой, чтобы у любых двух из них было не более 2 общих номеров между собой. Например.. 1 2 3 4 5 1 2 6 7 8 3 4 6 7 9 и т.д. Я так понимаю, такой набор можно выбрать многими разными способами, но мне достаточно одного, любого. Наверное, нужно задать какую-то формулу с оператором "если", которая будет по очереди прогонять все сочетания и сравнивать их с предыдущими "положительно" отобранными; если с каждым из них не более 2 общих чисел - добавлять эту комбинацию тоже в "положительный" список. Вопрос только в том, как задать это условие - "не более 2"?chib
Public Sub test() Dim arr1(1 To 5) As Byte, arr2(1 To 5) As Byte Dim maxR As Long, curR As Long, jR As Long Dim i As Byte, i2, j2 As Byte Dim flOut As Byte, flOut1 As Byte
maxR = 25 curR = 2 Cells(1, 6) = 1 Do While curR <= maxR
For i = 1 To 5 arr1(i) = Cells(curR, i) Next i For jR = 1 To curR - 1 flOut = 0 For i = 1 To 5 arr2(i) = Cells(jR, i) Next i For i2 = 1 To 5 For j2 = 1 To 5 flOut1 = 0 If arr1(i2) = arr2(j2) Then flOut1 = flOut1 + 1 flOut = flOut + flOut1 If flOut1 > 0 Then Exit For Next j2 If flOut > 2 Then Cells(curR, 6) = 0: Exit For Next i2 If flOut > 2 Then Exit For Else Cells(curR, 6) = 1 Next jR curR = curR + 1 Loop
End Sub
[/vba]
Макрос выводит флаг годности в 6 колонку. Его ещё доработать мальца надо.
Только макросом смог что-то изобразить
[vba]
Код
Public Sub test() Dim arr1(1 To 5) As Byte, arr2(1 To 5) As Byte Dim maxR As Long, curR As Long, jR As Long Dim i As Byte, i2, j2 As Byte Dim flOut As Byte, flOut1 As Byte
maxR = 25 curR = 2 Cells(1, 6) = 1 Do While curR <= maxR
For i = 1 To 5 arr1(i) = Cells(curR, i) Next i For jR = 1 To curR - 1 flOut = 0 For i = 1 To 5 arr2(i) = Cells(jR, i) Next i For i2 = 1 To 5 For j2 = 1 To 5 flOut1 = 0 If arr1(i2) = arr2(j2) Then flOut1 = flOut1 + 1 flOut = flOut + flOut1 If flOut1 > 0 Then Exit For Next j2 If flOut > 2 Then Cells(curR, 6) = 0: Exit For Next i2 If flOut > 2 Then Exit For Else Cells(curR, 6) = 1 Next jR curR = curR + 1 Loop
End Sub
[/vba]
Макрос выводит флаг годности в 6 колонку. Его ещё доработать мальца надо.Udik
Udik, спасибо! Я правильно понимаю, он каждое число проверяет на совпадение, если совпадает - единица, после этого складывает, и отбирает где сумма не больше двух? Не очень хорошо в макросах ориентируюсь
Udik, спасибо! Я правильно понимаю, он каждое число проверяет на совпадение, если совпадает - единица, после этого складывает, и отбирает где сумма не больше двух? Не очень хорошо в макросах ориентируюсьchib
Udik, видимо да. Прогнал макрос на реальных данных, осталась одна комбинация (самая первая). Хотя ясно, что это не так. ЗЫ: У меня вчера то же самое получилось. Пытался формулами отсеять в 3 этапа.
Udik, видимо да. Прогнал макрос на реальных данных, осталась одна комбинация (самая первая). Хотя ясно, что это не так. ЗЫ: У меня вчера то же самое получилось. Пытался формулами отсеять в 3 этапа. ShAM
Версия 2 В предыдущей не учёл, что отброшенные варианты проверять не надо. [vba]
Код
Public Sub test() Dim arr1(1 To 5) As Byte, arr2(1 To 5) As Byte Dim maxR As Long, curR As Long, jR As Long Dim i As Byte, i2, j2 As Byte Dim flOut As Byte, flOut1 As Byte
maxR = Range("A1").SpecialCells(xlLastCell).Row 'получаем номер строки последней заполненной ячейки в 1 колонке curR = 2 ActiveSheet.Columns(6).ClearContents Cells(1, 6) = 1
Do While curR <= maxR
For i = 1 To 5 arr1(i) = Cells(curR, i) Next i For jR = 1 To curR - 1 flOut = 0 If Cells(jR, 6) = 1 Then For i = 1 To 5 arr2(i) = Cells(jR, i) Next i For i2 = 1 To 5 For j2 = 1 To 5 flOut1 = 0 If arr1(i2) = arr2(j2) Then flOut1 = flOut1 + 1 flOut = flOut + flOut1 If flOut1 > 0 Then Exit For Next j2 If flOut > 2 Then Exit For Next i2 If flOut > 2 Then Exit For End If Next jR Cells(curR, 6) = Abs(flOut < 3) 'выводим флаг curR = curR + 1 Loop
В целом да, берёт очередную комбинацию и проверяет с каждой "годной", отобранной до этого. Если совпадений меньше трех - считает годной. Поэтому порядок комбинаций влияет на то, какие будут отобраны.
Версия 2 В предыдущей не учёл, что отброшенные варианты проверять не надо. [vba]
Код
Public Sub test() Dim arr1(1 To 5) As Byte, arr2(1 To 5) As Byte Dim maxR As Long, curR As Long, jR As Long Dim i As Byte, i2, j2 As Byte Dim flOut As Byte, flOut1 As Byte
maxR = Range("A1").SpecialCells(xlLastCell).Row 'получаем номер строки последней заполненной ячейки в 1 колонке curR = 2 ActiveSheet.Columns(6).ClearContents Cells(1, 6) = 1
Do While curR <= maxR
For i = 1 To 5 arr1(i) = Cells(curR, i) Next i For jR = 1 To curR - 1 flOut = 0 If Cells(jR, 6) = 1 Then For i = 1 To 5 arr2(i) = Cells(jR, i) Next i For i2 = 1 To 5 For j2 = 1 To 5 flOut1 = 0 If arr1(i2) = arr2(j2) Then flOut1 = flOut1 + 1 flOut = flOut + flOut1 If flOut1 > 0 Then Exit For Next j2 If flOut > 2 Then Exit For Next i2 If flOut > 2 Then Exit For End If Next jR Cells(curR, 6) = Abs(flOut < 3) 'выводим флаг curR = curR + 1 Loop
В целом да, берёт очередную комбинацию и проверяет с каждой "годной", отобранной до этого. Если совпадений меньше трех - считает годной. Поэтому порядок комбинаций влияет на то, какие будут отобраны.Udik
Udik, А если я захочу не 2, а 3 совпадения максимум, что мне надо будет изменить в макросе? Cells(curR, 6) = Abs(flOut < 3) здесь нужно тройку на четверку заменить? что-нибудь еще?
If flOut > 2 Then Exit For здесь двойку на тройку?
Udik, А если я захочу не 2, а 3 совпадения максимум, что мне надо будет изменить в макросе? Cells(curR, 6) = Abs(flOut < 3) здесь нужно тройку на четверку заменить? что-нибудь еще?
If flOut > 2 Then Exit For здесь двойку на тройку?chib
Public Sub test() Dim arr1(1 To 5) As Byte, arr2(1 To 5) As Byte Dim maxR As Long, curR As Long, jR As Long Dim i As Byte, i2, j2 As Byte Dim flOut As Byte, flOut1 As Byte Const numEq As Byte = 2 'количество допустимых совпадений
maxR = Range("A1").SpecialCells(xlLastCell).Row 'получаем номер строки последней заполненной ячейки в 1 колонке curR = 2 ActiveSheet.Columns(6).ClearContents Cells(1, 6) = 1
Do While curR <= maxR
For i = 1 To 5 arr1(i) = Cells(curR, i) Next i For jR = 1 To curR - 1 flOut = 0 If Cells(jR, 6) = 1 Then For i = 1 To 5 arr2(i) = Cells(jR, i) Next i For i2 = 1 To 5 For j2 = 1 To 5 flOut1 = 0 If arr1(i2) = arr2(j2) Then flOut1 = flOut1 + 1 flOut = flOut + flOut1 If flOut1 > 0 Then Exit For Next j2 If flOut > numEq Then Exit For Next i2 If flOut > numEq Then Exit For End If Next jR Cells(curR, 6) = Abs(Not (flOut > numEq)) 'выводим флаг curR = curR + 1 Loop
End Sub
[/vba]
Сделал, чтобы в одном месте править
[vba]
Код
Public Sub test() Dim arr1(1 To 5) As Byte, arr2(1 To 5) As Byte Dim maxR As Long, curR As Long, jR As Long Dim i As Byte, i2, j2 As Byte Dim flOut As Byte, flOut1 As Byte Const numEq As Byte = 2 'количество допустимых совпадений
maxR = Range("A1").SpecialCells(xlLastCell).Row 'получаем номер строки последней заполненной ячейки в 1 колонке curR = 2 ActiveSheet.Columns(6).ClearContents Cells(1, 6) = 1
Do While curR <= maxR
For i = 1 To 5 arr1(i) = Cells(curR, i) Next i For jR = 1 To curR - 1 flOut = 0 If Cells(jR, 6) = 1 Then For i = 1 To 5 arr2(i) = Cells(jR, i) Next i For i2 = 1 To 5 For j2 = 1 To 5 flOut1 = 0 If arr1(i2) = arr2(j2) Then flOut1 = flOut1 + 1 flOut = flOut + flOut1 If flOut1 > 0 Then Exit For Next j2 If flOut > numEq Then Exit For Next i2 If flOut > numEq Then Exit For End If Next jR Cells(curR, 6) = Abs(Not (flOut > numEq)) 'выводим флаг curR = curR + 1 Loop
Есть массив чисел 1, 2, 3....16, из них нужно сначала выбрать все возможные сочетания по 5
На вопрос из первого сообщения относительно генерации сочетаний 5 из 16 могу предложить макрос: [vba]
Код
Sub MyCombin() Dim a&(), i&, j&, m&, n&, p& n = Val(InputBox("n =", , 16)) m = Val(InputBox("m =", , 5)) If n < m Or m < 1 Then Exit Sub
ReDim a&(1 To m), b&(1 To WorksheetFunction.Combin(n, m), 1 To m) For i = 1 To m: a(i) = i: Next i If m = n Then p = 1 Else p = m
[a1].CurrentRegion.ClearContents Do j = j + 1 For i = 1 To m: b(j, i) = a(i): Next i If a(m) = n Then p = p - 1 Else p = m If p Then For i = m To p Step -1 a(i) = a(p) + i - p + 1 Next i End If Loop While p [a1].Resize(UBound(b), m) = b End Sub
Есть массив чисел 1, 2, 3....16, из них нужно сначала выбрать все возможные сочетания по 5
На вопрос из первого сообщения относительно генерации сочетаний 5 из 16 могу предложить макрос: [vba]
Код
Sub MyCombin() Dim a&(), i&, j&, m&, n&, p& n = Val(InputBox("n =", , 16)) m = Val(InputBox("m =", , 5)) If n < m Or m < 1 Then Exit Sub
ReDim a&(1 To m), b&(1 To WorksheetFunction.Combin(n, m), 1 To m) For i = 1 To m: a(i) = i: Next i If m = n Then p = 1 Else p = m
[a1].CurrentRegion.ClearContents Do j = j + 1 For i = 1 To m: b(j, i) = a(i): Next i If a(m) = n Then p = p - 1 Else p = m If p Then For i = m To p Step -1 a(i) = a(p) + i - p + 1 Next i End If Loop While p [a1].Resize(UBound(b), m) = b End Sub
вопрос ради любопытства, необязательный, в рамках этой же задачи. Как можно минимизировать количество этих наборов с флагом "1"? Это уже скорее математическая задача, правда. Я немножко погонял выборки, пофильтровал списки..
Первая идея была такая: сначала выбрать все наборы, у которых 0 совпадений, отсортировать по убыванию по столбцу с флагами чтобы они наверх всплыли, потом "оставшиеся" отфильтровать по наборам с 1 совпадением, снова отсортировать, и потом уже - прогнать то же самое с двумя совпадениями.
Вторая идея. есть у нас к примеру наборы: 1 2 3 4 5 1 2 6 7 8 1 2 9 10 11 1 2 12 13 14 и т.д. везде фигурирует "1 2". Если как-нибудь ограничить количество наборов, у которых повторяется именно набор "1 2" - то тогда такие наборы будут вместе иметь более широкий "охват" и нам понадобится меньше наборов, чтобы "покрыть" ими всю выборку. Было бы интересно подумать как это можно осуществить.
вопрос ради любопытства, необязательный, в рамках этой же задачи. Как можно минимизировать количество этих наборов с флагом "1"? Это уже скорее математическая задача, правда. Я немножко погонял выборки, пофильтровал списки..
Первая идея была такая: сначала выбрать все наборы, у которых 0 совпадений, отсортировать по убыванию по столбцу с флагами чтобы они наверх всплыли, потом "оставшиеся" отфильтровать по наборам с 1 совпадением, снова отсортировать, и потом уже - прогнать то же самое с двумя совпадениями.
Вторая идея. есть у нас к примеру наборы: 1 2 3 4 5 1 2 6 7 8 1 2 9 10 11 1 2 12 13 14 и т.д. везде фигурирует "1 2". Если как-нибудь ограничить количество наборов, у которых повторяется именно набор "1 2" - то тогда такие наборы будут вместе иметь более широкий "охват" и нам понадобится меньше наборов, чтобы "покрыть" ими всю выборку. Было бы интересно подумать как это можно осуществить.chib
раз все-таки тема в разделе Вопросы по Excel, предложу формульный вариант (только для небольшого количества исходных данных, ибо формула массивная и вычисляется медленно) в файле из 4 поста добавил сверху пустую строку, в F1 число 2 (кол-во повторов), ниже формула
раз все-таки тема в разделе Вопросы по Excel, предложу формульный вариант (только для небольшого количества исходных данных, ибо формула массивная и вычисляется медленно) в файле из 4 поста добавил сверху пустую строку, в F1 число 2 (кол-во повторов), ниже формула
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
В предыдущей не учёл, что отброшенные варианты проверять не надо. 
