В прошлый раз очень продуктивно пообщались на тему массивов, ещё раз спасибо всем, кто принимал участие. Теперь хочу прикоснуться к тонким материям комбинаторики.
Предыстория под спойлером.
Несколько раз пробовал анализировать алгоритм Нарайаны, опубликованный Константином "Gustav'om". Нашёл используемую математику выходящей за рамки моего текущего разумения и решил пока сделать первые самостоятельные шаги в комбинаторике, результатом чего на данном этапе выступает мой код ниже. Изначальный вопрос был: как можно регулировать уровень вложенности циклов. Код Константина использовал "Do While" метод, который я и позаимствовал.
Также упомяну, что сейчас передо мной стоит один открытый вопрос знакомого по созданию сочетаний без повторений с условием. В связи с чем разыскиваю "удочку".
Описание моего кода под спойлером.
На активном листе код стирает данные из столбца А, предлагает пользователю выбрать максимальное количество символов в комбинациях, после чего генерирует все возможные комбинации из 7-ми нот от ноты ля (А в общепринятом начертании) до ноты соль (G) без учёта октав. Если задать массиву arrA другую размерность и присвоить ему другие значения - комбинации будут подбираться из чего угодно.
Прошу помочь с решением следующих вопросов:
1). [Важно] Как можно вывести на экран только комбинации нот заданного пользователем количества знаков? (Переменная А) 2). [Второстепенно] Как можно оптимизировать действующий код? 3). [Второстепенно] Как можно ускорить действующий код?
Вашему вниманию собственно сам код:
[vba]
Код
Option Explicit Option Base 1
Sub Roll_Out()
'Author: Roman Rioran Voronov 'Date: the 1-st of October, 2014 'Feedback: voronov_rv@mail.ru
'Programm to roll all combinations of pre-selected symbols 'User itself decides by how much symbols to bound combinations 'Be aware not to enter anything higher 6 to inputbox 'Be sure that "Option Base 1" is enabled
Dim A As Long 'How much maximum positions do we need Dim i As Long 'To roll resul rows Dim RowsX As Long 'To count done material Dim RowsY As Long 'To count last pack Dim X As Long 'To roll the main inner circle and the pre-circle Dim XX As Long 'To roll the main outer circle Dim arrA As Variant 'Holder of all needed symbols
Columns(1).ClearContents
A = InputBox("How much symbols do we need?") If A = 0 Then Exit Sub Application.ScreenUpdating = False
'The pre-circle For X = 1 To UBound(arrA): Cells(X, 1).Value = arrA(X): Next X RowsX = Cells(Rows.Count, 1).End(xlUp).Row
'The main circle Do While Len(Cells(RowsX, 1).Value) <> A For XX = RowsY To RowsX For X = 1 To UBound(arrA) Cells(i, 1).Value = Cells(XX, 1).Value & arrA(X) i = i + 1 Next X Next XX RowsY = RowsX + 1 RowsX = Cells(Rows.Count, 1).End(xlUp).Row Loop
Application.ScreenUpdating = True
End Sub
[/vba] Заранее спасибо.
Всем привет и хорошего настроения!
В прошлый раз очень продуктивно пообщались на тему массивов, ещё раз спасибо всем, кто принимал участие. Теперь хочу прикоснуться к тонким материям комбинаторики.
Предыстория под спойлером.
Несколько раз пробовал анализировать алгоритм Нарайаны, опубликованный Константином "Gustav'om". Нашёл используемую математику выходящей за рамки моего текущего разумения и решил пока сделать первые самостоятельные шаги в комбинаторике, результатом чего на данном этапе выступает мой код ниже. Изначальный вопрос был: как можно регулировать уровень вложенности циклов. Код Константина использовал "Do While" метод, который я и позаимствовал.
Также упомяну, что сейчас передо мной стоит один открытый вопрос знакомого по созданию сочетаний без повторений с условием. В связи с чем разыскиваю "удочку".
Описание моего кода под спойлером.
На активном листе код стирает данные из столбца А, предлагает пользователю выбрать максимальное количество символов в комбинациях, после чего генерирует все возможные комбинации из 7-ми нот от ноты ля (А в общепринятом начертании) до ноты соль (G) без учёта октав. Если задать массиву arrA другую размерность и присвоить ему другие значения - комбинации будут подбираться из чего угодно.
Прошу помочь с решением следующих вопросов:
1). [Важно] Как можно вывести на экран только комбинации нот заданного пользователем количества знаков? (Переменная А) 2). [Второстепенно] Как можно оптимизировать действующий код? 3). [Второстепенно] Как можно ускорить действующий код?
Вашему вниманию собственно сам код:
[vba]
Код
Option Explicit Option Base 1
Sub Roll_Out()
'Author: Roman Rioran Voronov 'Date: the 1-st of October, 2014 'Feedback: voronov_rv@mail.ru
'Programm to roll all combinations of pre-selected symbols 'User itself decides by how much symbols to bound combinations 'Be aware not to enter anything higher 6 to inputbox 'Be sure that "Option Base 1" is enabled
Dim A As Long 'How much maximum positions do we need Dim i As Long 'To roll resul rows Dim RowsX As Long 'To count done material Dim RowsY As Long 'To count last pack Dim X As Long 'To roll the main inner circle and the pre-circle Dim XX As Long 'To roll the main outer circle Dim arrA As Variant 'Holder of all needed symbols
Columns(1).ClearContents
A = InputBox("How much symbols do we need?") If A = 0 Then Exit Sub Application.ScreenUpdating = False
'The pre-circle For X = 1 To UBound(arrA): Cells(X, 1).Value = arrA(X): Next X RowsX = Cells(Rows.Count, 1).End(xlUp).Row
'The main circle Do While Len(Cells(RowsX, 1).Value) <> A For XX = RowsY To RowsX For X = 1 To UBound(arrA) Cells(i, 1).Value = Cells(XX, 1).Value & arrA(X) i = i + 1 Next X Next XX RowsY = RowsX + 1 RowsX = Cells(Rows.Count, 1).End(xlUp).Row Loop
Sub Notes() Dim i&, j&, k&, n&, m&, txt$ n = Val(InputBox("n =", , 5)) If n < 1 Then Exit Sub ReDim out$(1 To 7 ^ n, 1 To 1) For i = 0 To 7 ^ n - 1 m = i txt = "" For k = 1 To n txt = Chr$(65 + (m Mod 7)) & txt m = m \ 7 Next k j = j + 1 out(j, 1) = txt Next i Columns(1).ClearContents [a1].Resize(j, 1) = out End Sub
[/vba]
[vba]
Код
Sub Notes() Dim i&, j&, k&, n&, m&, txt$ n = Val(InputBox("n =", , 5)) If n < 1 Then Exit Sub ReDim out$(1 To 7 ^ n, 1 To 1) For i = 0 To 7 ^ n - 1 m = i txt = "" For k = 1 To n txt = Chr$(65 + (m Mod 7)) & txt m = m \ 7 Next k j = j + 1 out(j, 1) = txt Next i Columns(1).ClearContents [a1].Resize(j, 1) = out End Sub
MCH, попробовал разобрать на молекулы твой код, проверь пожалуйста комментарии.
[vba]
Код
Sub Notes_by_MCH_RioReforged()
Dim i As Long 'Для перебора строк массива циклом от 0 Dim j As Long 'Для поиска строки массива для вставки новой комбинации Dim k As Long 'Для цикла по символам комбинации Dim n As Long 'Требуемое количество символов в результате Dim m As Long 'Для подбора комбинации Dim txt As String 'Текст формируемой комбинации
'Возвращает числовые значения из введенных пользователем символов n = Val(InputBox("n =", , 5)) 'Если символов меньше 1, то выходим из процедуры If n < 1 Then Exit Sub
'Объявляем 2-мерный массив с количеством строк = количество возможных комбинаций ReDim out$(1 To 7 ^ n, 1 To 1)
'Перебираем строки массива For i = 0 To 7 ^ n - 1 m = i txt = "" 'Для каждой новой строки обнуляем текст For k = 1 To n 'Цикл по символам 'На каждом шаге слева от строки добавляем символ 'символ определяется остатком от деления "номера строки - 1" на 7 txt = Chr$(65 + (m Mod 7)) & txt 'Если представить "номер строки - 1" в семиричном исчислении, 'то далее мы переходим к следующему разряду семиричного числа 'обратное деление возвращает целое число m = m \ 7 Next k 'Находим следующую для заполнения строку массива j = j + 1 'Вносим подобранную комбинацию в массив out(j, 1) = txt Next i 'Очищаем столбец Columns(1).ClearContents 'Выводим массив на лист [a1].Resize(j, 1) = out
End Sub
[/vba] В принципе, без j переменной можно обойтись. Это сделают out(i + 1, 1) = txt и Resize(Ubound(out), 1).
Не понимаю, зачем объявлять массив двухмерным. Вручную отдельно урезал его до 1-мерного и на выходе получал некорректные значения. Интересно, где и в чём происходит перелом, что может 2-мерный, в чем буксует одномерный массив?
MCH, попробовал разобрать на молекулы твой код, проверь пожалуйста комментарии.
[vba]
Код
Sub Notes_by_MCH_RioReforged()
Dim i As Long 'Для перебора строк массива циклом от 0 Dim j As Long 'Для поиска строки массива для вставки новой комбинации Dim k As Long 'Для цикла по символам комбинации Dim n As Long 'Требуемое количество символов в результате Dim m As Long 'Для подбора комбинации Dim txt As String 'Текст формируемой комбинации
'Возвращает числовые значения из введенных пользователем символов n = Val(InputBox("n =", , 5)) 'Если символов меньше 1, то выходим из процедуры If n < 1 Then Exit Sub
'Объявляем 2-мерный массив с количеством строк = количество возможных комбинаций ReDim out$(1 To 7 ^ n, 1 To 1)
'Перебираем строки массива For i = 0 To 7 ^ n - 1 m = i txt = "" 'Для каждой новой строки обнуляем текст For k = 1 To n 'Цикл по символам 'На каждом шаге слева от строки добавляем символ 'символ определяется остатком от деления "номера строки - 1" на 7 txt = Chr$(65 + (m Mod 7)) & txt 'Если представить "номер строки - 1" в семиричном исчислении, 'то далее мы переходим к следующему разряду семиричного числа 'обратное деление возвращает целое число m = m \ 7 Next k 'Находим следующую для заполнения строку массива j = j + 1 'Вносим подобранную комбинацию в массив out(j, 1) = txt Next i 'Очищаем столбец Columns(1).ClearContents 'Выводим массив на лист [a1].Resize(j, 1) = out
End Sub
[/vba] В принципе, без j переменной можно обойтись. Это сделают out(i + 1, 1) = txt и Resize(Ubound(out), 1).
Не понимаю, зачем объявлять массив двухмерным. Вручную отдельно урезал его до 1-мерного и на выходе получал некорректные значения. Интересно, где и в чём происходит перелом, что может 2-мерный, в чем буксует одномерный массив?Rioran
Роман, Москва, voronov_rv@mail.ru Яндекс-Деньги: 41001312674279
Сообщение отредактировал Rioran - Среда, 01.10.2014, 16:36
где и в чём происходит перелом, что может 2-мерный, в чем буксует одномерный массив?
Двумерный массив нужен для выгрузки на лист вертикально (т.к. имеем j строк и 1 столбец), если сделать его одномерным, то нужно будет применять перед выгрузка Application.Transpose (ограничение в 65536 значений элемента массива).
в данном случае можно и без j, а resize сделать по переменно i, т.к. после выполнения цикла переменная i будет иметь значение равное количеству элементов
можно еще обойтись без переменной txt, а сразу формировать строки в массиве out
[vba]
Код
Sub Notes() Dim i&, j&, n&, m& n = Val(InputBox("n =", , 5)) If n < 1 Then Exit Sub ReDim out$(1 To 7 ^ n, 1 To 1) For i = 0 To 7 ^ n - 1 m = i For j = 1 To n out(i + 1, 1) = Chr$(65 + m Mod 7) & out(i + 1, 1) m = m \ 7 Next j Next i Columns(1).ClearContents [a1].Resize(i, 1) = out End Sub
где и в чём происходит перелом, что может 2-мерный, в чем буксует одномерный массив?
Двумерный массив нужен для выгрузки на лист вертикально (т.к. имеем j строк и 1 столбец), если сделать его одномерным, то нужно будет применять перед выгрузка Application.Transpose (ограничение в 65536 значений элемента массива).
в данном случае можно и без j, а resize сделать по переменно i, т.к. после выполнения цикла переменная i будет иметь значение равное количеству элементов
можно еще обойтись без переменной txt, а сразу формировать строки в массиве out
[vba]
Код
Sub Notes() Dim i&, j&, n&, m& n = Val(InputBox("n =", , 5)) If n < 1 Then Exit Sub ReDim out$(1 To 7 ^ n, 1 To 1) For i = 0 To 7 ^ n - 1 m = i For j = 1 To n out(i + 1, 1) = Chr$(65 + m Mod 7) & out(i + 1, 1) m = m \ 7 Next j Next i Columns(1).ClearContents [a1].Resize(i, 1) = out End Sub
Вариант SQL запросом может быть быстрей. На листе Лист1 в столбце A поместить A,B,C,D,E,F,G в каждой строке ячейки. Результат выводится на Лист2.
[vba]
Код
Public Sub RefreshData() 'Created using add-in ActiveTables Dim strConnection As String Dim strSQL As String strConnection = iif(Val(Application.Version) < 12,"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=NO;IMEX=3';","OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=NO;IMEX=3';") strSQL = "SELECT л1.F1+л2.F1+л3.F1+л4.F1+л5.F1+л6.F1+л7.F1 FROM [Лист1$] as л1,[Лист1$] as л2,[Лист1$] as л3,[Лист1$] as л4,[Лист1$] as л5,[Лист1$] as л6,[Лист1$] as л7" With ThisWorkbook.Sheets(2) .UsedRange.Clear With .QueryTables.Add(strConnection, .Range("A1"), strSQL) .Refresh False .Delete End With End With End Sub
[/vba]
Вариант SQL запросом может быть быстрей. На листе Лист1 в столбце A поместить A,B,C,D,E,F,G в каждой строке ячейки. Результат выводится на Лист2.
[vba]
Код
Public Sub RefreshData() 'Created using add-in ActiveTables Dim strConnection As String Dim strSQL As String strConnection = iif(Val(Application.Version) < 12,"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=NO;IMEX=3';","OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=NO;IMEX=3';") strSQL = "SELECT л1.F1+л2.F1+л3.F1+л4.F1+л5.F1+л6.F1+л7.F1 FROM [Лист1$] as л1,[Лист1$] as л2,[Лист1$] as л3,[Лист1$] as л4,[Лист1$] as л5,[Лист1$] as л6,[Лист1$] as л7" With ThisWorkbook.Sheets(2) .UsedRange.Clear With .QueryTables.Add(strConnection, .Range("A1"), strSQL) .Refresh False .Delete End With End With End Sub
PowerBoy, спасибо за вариант, но он себя не оправдал.
Протестировал три кода - Ваш, мой и MCH. 7 позиций, 800к+ строк. Каждому коду приладил Application.Screenupdating и отображение Now в начале и конце. Результаты:
3-е место: Ваш код за 45 секунд 2-е место: Мой код за 33 секунды, при том что генерирует лишние числа меньшей разрядности 1-е место: MCH код за 4 секунды
PowerBoy, спасибо за вариант, но он себя не оправдал.
Протестировал три кода - Ваш, мой и MCH. 7 позиций, 800к+ строк. Каждому коду приладил Application.Screenupdating и отображение Now в начале и конце. Результаты:
3-е место: Ваш код за 45 секунд 2-е место: Мой код за 33 секунды, при том что генерирует лишние числа меньшей разрядности 1-е место: MCH код за 4 секундыRioran
Роман, Москва, voronov_rv@mail.ru Яндекс-Деньги: 41001312674279
Просто из спортивного интереса переписал свой код.
[vba]
Код
Option Explicit Option Base 1
Sub Rio_Combos()
Dim ArrX Dim ArrC Dim Cols As Long 'Columns for results Dim Elms As Long 'How much basic elements Dim NumX As Long 'How much result rows Dim C As Long 'To provide result Dim B As Long 'To roll Cols Dim A As Long 'To roll NumX
A = Cells(1, 3).End(xlDown).Row B = Cells(1, 3).End(xlToRight).Column Range(Cells(1, 3), Cells(A, B)).Value = ""
Cols = InputBox("How much columns do you want? Only integer values.", "Enter value", 3) Elms = Cells(Rows.Count, 1).End(xlUp).Row NumX = Elms ^ Cols
If NumX > 1000000 Then MsgBox "Sorry, too much calculations, I quit." Exit Sub End If
ReDim ArrX(NumX, Cols) ReDim ArrC(Elms)
For B = 1 To Elms ArrC(B) = Cells(B, 1).Value Next B
B = Cols
Do While B > 0 C = 1 For A = 1 To NumX If C > Elms Then C = 1 ArrX(A, Cols + 1 - B) = ArrC(C) If A Mod Elms ^ (B - 1) = 0 Then C = C + 1 Next A B = B - 1 Loop
Cells(1, 3).Resize(NumX, Cols).Value = ArrX
End Sub
[/vba]
Просто из спортивного интереса переписал свой код.
[vba]
Код
Option Explicit Option Base 1
Sub Rio_Combos()
Dim ArrX Dim ArrC Dim Cols As Long 'Columns for results Dim Elms As Long 'How much basic elements Dim NumX As Long 'How much result rows Dim C As Long 'To provide result Dim B As Long 'To roll Cols Dim A As Long 'To roll NumX
A = Cells(1, 3).End(xlDown).Row B = Cells(1, 3).End(xlToRight).Column Range(Cells(1, 3), Cells(A, B)).Value = ""
Cols = InputBox("How much columns do you want? Only integer values.", "Enter value", 3) Elms = Cells(Rows.Count, 1).End(xlUp).Row NumX = Elms ^ Cols
If NumX > 1000000 Then MsgBox "Sorry, too much calculations, I quit." Exit Sub End If
ReDim ArrX(NumX, Cols) ReDim ArrC(Elms)
For B = 1 To Elms ArrC(B) = Cells(B, 1).Value Next B
B = Cols
Do While B > 0 C = 1 For A = 1 To NumX If C > Elms Then C = 1 ArrX(A, Cols + 1 - B) = ArrC(C) If A Mod Elms ^ (B - 1) = 0 Then C = C + 1 Next A B = B - 1 Loop
То же самое, но в одной строке результата могут быть только уникальные значения.
[vba]
Код
Option Explicit Option Base 1
Sub Rio_Combos()
Dim ArrX Dim ArrC Dim ArrW Dim Cols As Long 'Columns for results Dim Elms As Long 'How much basic elements Dim NumX As Long 'How much result rows Dim blnX As Byte 'May we use this? Dim D As Long 'On what to divide Dim C As Long 'To provide result Dim B As Long 'To roll Cols Dim A As Long 'To roll NumX Dim q As Long 'To fill ArrC Dim i As Long 'To roll all Dim j As Long 'To roll all
A = Cells(1, 3).End(xlDown).Row B = Cells(1, 3).End(xlToRight).Column Range(Cells(1, 3), Cells(A, B)).Value = ""
Cols = InputBox("How much columns do you want? Only integer values.", "Enter value", 3) Elms = Cells(Rows.Count, 1).End(xlUp).Row If Cols > Elms Then Cols = Elms NumX = RioFact(Elms) / RioFact(Elms - Cols)
If NumX > 1000000 Then MsgBox "Sorry, too much calculations, I quit." Exit Sub End If
ReDim ArrX(NumX, Cols) ReDim ArrC(Elms)
For B = 1 To Elms ArrC(B) = Cells(B, 1).Value Next B
ArrW = ArrC
B = 1 D = 1
Do While B <= Cols C = 1 If B > 1 Then ReDim ArrC(Elms + 1 - B) D = D * UBound(ArrC) For A = 1 To NumX If C = 1 And B > 1 Then q = 1 For i = 1 To Elms blnX = 1 For j = 1 To B - 1 If ArrX(A, j) = ArrW(i) Then blnX = 0 Exit For End If Next j If blnX = 1 Then ArrC(q) = ArrW(i) q = q + 1 End If Next i End If ArrX(A, B) = ArrC(C) If A Mod NumX / D = 0 Then C = C + 1 If C > UBound(ArrC) Then C = 1 Next A B = B + 1 Loop
Cells(1, 3).Resize(NumX, Cols).Value = ArrX
End Sub
Private Function RioFact(Z As Long) As Long
Dim i As Long RioFact = 1
For i = 1 To Z RioFact = RioFact * i Next i
End Function
[/vba]
То же самое, но в одной строке результата могут быть только уникальные значения.
[vba]
Код
Option Explicit Option Base 1
Sub Rio_Combos()
Dim ArrX Dim ArrC Dim ArrW Dim Cols As Long 'Columns for results Dim Elms As Long 'How much basic elements Dim NumX As Long 'How much result rows Dim blnX As Byte 'May we use this? Dim D As Long 'On what to divide Dim C As Long 'To provide result Dim B As Long 'To roll Cols Dim A As Long 'To roll NumX Dim q As Long 'To fill ArrC Dim i As Long 'To roll all Dim j As Long 'To roll all
A = Cells(1, 3).End(xlDown).Row B = Cells(1, 3).End(xlToRight).Column Range(Cells(1, 3), Cells(A, B)).Value = ""
Cols = InputBox("How much columns do you want? Only integer values.", "Enter value", 3) Elms = Cells(Rows.Count, 1).End(xlUp).Row If Cols > Elms Then Cols = Elms NumX = RioFact(Elms) / RioFact(Elms - Cols)
If NumX > 1000000 Then MsgBox "Sorry, too much calculations, I quit." Exit Sub End If
ReDim ArrX(NumX, Cols) ReDim ArrC(Elms)
For B = 1 To Elms ArrC(B) = Cells(B, 1).Value Next B
ArrW = ArrC
B = 1 D = 1
Do While B <= Cols C = 1 If B > 1 Then ReDim ArrC(Elms + 1 - B) D = D * UBound(ArrC) For A = 1 To NumX If C = 1 And B > 1 Then q = 1 For i = 1 To Elms blnX = 1 For j = 1 To B - 1 If ArrX(A, j) = ArrW(i) Then blnX = 0 Exit For End If Next j If blnX = 1 Then ArrC(q) = ArrW(i) q = q + 1 End If Next i End If ArrX(A, B) = ArrC(C) If A Mod NumX / D = 0 Then C = C + 1 If C > UBound(ArrC) Then C = 1 Next A B = B + 1 Loop
Объединил последние две наработки в одну и добавил перебор сочетаний:
[vba]
Код
Option Explicit
Sub Rio_Combinations()
'Author: Roman "Rioran" Voronov 'Date: the 3-rd of December, 2014 'Feedback: voronov_rv@mail.ru
'Code that gives you all possible object combinations
Dim ArrA() As String 'Container of basic objects Dim ArrX() As String 'Array for binary values Dim Rslt() As String 'For results Dim A As Long 'To roll ArrX Dim B As Byte 'To find ArrA length Dim C As Byte 'To roll single values Dim D As Byte 'Column Position in Rslt()
A = Cells(1, 3).End(xlDown).Row B = Cells(1, 3).End(xlToRight).Column Range(Cells(1, 3), Cells(A, B)).Value = ""
B = Cells(Rows.Count, 1).End(xlUp).Row
If B < 2 Or B > 20 Then MsgBox "Sorry, too much calculations, I quit." Exit Sub End If
ReDim ArrX((2 ^ B) - 2) ReDim ArrA(B - 1) ReDim Rslt(UBound(ArrX), B - 1)
For A = 0 To UBound(ArrA) ArrA(A) = Cells(A + 1, 1).Value Next A
For A = 0 To UBound(ArrX) ArrX(A) = RioDTB(A + 1, B) D = 0 For C = 1 To B If Mid(ArrX(A), C, 1) = 1 Then Rslt(A, D) = ArrA(C - 1) D = D + 1 End If Next C Next A
For i = 30 To 0 Step -1 TwoX(i) = 2 ^ i Select Case X Case Is > TwoX(i) X = X - TwoX(i) RioDTB = RioDTB & 1 Case Is = TwoX(i) RioDTB = RioDTB & 1 X = 0 Case Is < TwoX(i) RioDTB = RioDTB & 0 End Select Next i
RioDTB = Right(RioDTB, Y)
If Len(RioDTB) < Y Then RioDTB = String(Y - Len(RioDTB), 0) & RioDTB End If
End Function
[/vba]
Объединил последние две наработки в одну и добавил перебор сочетаний:
[vba]
Код
Option Explicit
Sub Rio_Combinations()
'Author: Roman "Rioran" Voronov 'Date: the 3-rd of December, 2014 'Feedback: voronov_rv@mail.ru
'Code that gives you all possible object combinations
Dim ArrA() As String 'Container of basic objects Dim ArrX() As String 'Array for binary values Dim Rslt() As String 'For results Dim A As Long 'To roll ArrX Dim B As Byte 'To find ArrA length Dim C As Byte 'To roll single values Dim D As Byte 'Column Position in Rslt()
A = Cells(1, 3).End(xlDown).Row B = Cells(1, 3).End(xlToRight).Column Range(Cells(1, 3), Cells(A, B)).Value = ""
B = Cells(Rows.Count, 1).End(xlUp).Row
If B < 2 Or B > 20 Then MsgBox "Sorry, too much calculations, I quit." Exit Sub End If
ReDim ArrX((2 ^ B) - 2) ReDim ArrA(B - 1) ReDim Rslt(UBound(ArrX), B - 1)
For A = 0 To UBound(ArrA) ArrA(A) = Cells(A + 1, 1).Value Next A
For A = 0 To UBound(ArrX) ArrX(A) = RioDTB(A + 1, B) D = 0 For C = 1 To B If Mid(ArrX(A), C, 1) = 1 Then Rslt(A, D) = ArrA(C - 1) D = D + 1 End If Next C Next A
For i = 30 To 0 Step -1 TwoX(i) = 2 ^ i Select Case X Case Is > TwoX(i) X = X - TwoX(i) RioDTB = RioDTB & 1 Case Is = TwoX(i) RioDTB = RioDTB & 1 X = 0 Case Is < TwoX(i) RioDTB = RioDTB & 0 End Select Next i
RioDTB = Right(RioDTB, Y)
If Len(RioDTB) < Y Then RioDTB = String(Y - Len(RioDTB), 0) & RioDTB End If