Генератор перестановок

[cent]

Необходимо создать модуль, который будет генерировать все возможные перестановки элементов некоторого множества.
Поиск привел на такие источники:
Генерация перестановок в антилексикографическом порядке (на Си и на Прологе)
Генераторы перестановок
Размещение (Wiki)
но в них либо теория, либо готовые решения на языках программирования, отличных от VBA

Может кто-то сможет интерпретировать коды в VBA?
Или хотя бы подскажите алгоритм, код сам напишу.


Например: есть множество из 4х чисел: 1,2,3,4.
Необходимо сгенерировать все возможные их размещения, при этом каждое число должно присутствовать в варианте 1 раз.
Вот такой результат должен получиться:

1	2	3	4
1	2	4	3
1	3	2	4
1	3	4	2
1	4	2	3
1	4	3	2
2	1	3	4
2	1	4	3
2	3	1	4
2	3	4	1
2	4	1	3
2	4	3	1
3	1	2	4
3	1	4	2
3	2	1	4
3	2	4	1
3	4	1	2
3	4	2	1
4	1	2	3
4	1	3	2
4	2	1	3
4	2	3	1
4	3	1	2
4	3	2	1

Эта последовательность была сделана вручную Исходя из того, что существует несколько методов расстановки, результат может отличаться только в последовательности комбинаций.

[EducatedFool]

Попробуйте такой вариант:

Dim coll As Collection

Sub Sm(AlreadyS As String, S As String)
    If Len(S) = 1 Then coll.Add AlreadyS & S: Exit Sub
    For i = 1 To Len(S): Sm AlreadyS + Mid$(S, i, 1), Left$(S, i - 1) & Mid$(S, i + 1): Next
End Sub

Sub ЗаполнитьЯчейкиПерестановками(ByVal ТекстоваяСтрока As String, ByRef ПерваяЯчейка As Range)
    Dim ra As Range, ДлинаСтроки As Long
    ДлинаСтроки = Len(ТекстоваяСтрока): If ДлинаСтроки < 1 Or ДлинаСтроки > 9 Then MsgBox "error": Exit Sub

    Set coll = New Collection: Sm "", ТекстоваяСтрока

    Set ra = ПерваяЯчейка.Cells(1).Resize(coll.Count, ДлинаСтроки)
    Dim arr(): ReDim arr(1 To coll.Count, 1 To ДлинаСтроки): c = 1

    For Each Item In coll
        For i = 1 To ДлинаСтроки: arr(c, i) = Mid$(Item, i, 1): Next: c = c + 1
    Next
    ra.Value = arr    ' переносим массив на лист
    ra.EntireColumn.AutoFit
End Sub

Sub ЗаполнитьЯчейкиСпискомЗначений(ByVal ТекстоваяСтрока As String, ByRef ПерваяЯчейка As Range)
    Dim ra As Range, ДлинаСтроки As Long
    ДлинаСтроки = Len(ТекстоваяСтрока): If ДлинаСтроки < 1 Or ДлинаСтроки > 9 Then MsgBox "error": Exit Sub

    Set coll = New Collection: Sm "", ТекстоваяСтрока

    Set ra = ПерваяЯчейка.Cells(1).Resize(coll.Count)
    Dim arr(): ReDim arr(1 To coll.Count, 1 To 1): c = 1

    For Each Item In coll
        For i = 1 To ДлинаСтроки: arr(c, 1) = Item: Next: c = c + 1
    Next
    ra.Value = arr    ' переносим массив на лист
    ra.EntireColumn.AutoFit
End Sub

Sub Пример()
    ЗаполнитьЯчейкиСпискомЗначений "abcde", Worksheets.Add.Cells(2, 2)
    ЗаполнитьЯчейкиПерестановками "12345", [e4]
End Sub

Запустите макрос Пример

Есть и другие, более эффективные и быстрые алгоритмы.
Но для строк небольшой длины и этот работает неплохо.


Если Вам нужно получить только уникальные перестановки,

(например, для такого варианта)

Sub Пример()
    ЗаполнитьЯчейкиСпискомЗначений "aaab", Worksheets.Add.Cells(2, 2)
    ЗаполнитьЯчейкиПерестановками "12122", [e4]
End Sub

то используйте следующий вариант процедуры Sm:

Sub Sm(AlreadyS As String, S As String)
    On Local Error Resume Next
    If Len(S) = 1 Then p = AlreadyS & S: coll.Add p, p & "a": Exit Sub
    For i = 1 To Len(S): Sm AlreadyS + Mid$(S, i, 1), Left$(S, i - 1) & Mid$(S, i + 1): Next
End Sub

[EducatedFool]

Сообщение от cent

Необходимо создать модуль, который будет генерировать все возможные перестановки элементов...

Необходимо сгенерировать все возможные их размещения, при этом каждое число должно присутствовать в варианте 1 раз.

Перестановки и размещения - это разные термины...

По поводу нужных алгоритмов - в Интернете их множество (в том числе и на VB)

Но для решения данной задачи лучше использовать алгоритмы без рекурсии, - такие как, например, этот
Осталось только найти аналог этого кода на VB.

Готовые алгоритмы можно поискать здесь

Я же взял за основу код из этой темы.