Максимально просто про перебор комбинаций в реальных бизнес-задачах

Если начать искать материал про перебор комбинаций, возникает масса примеров как перебрать все сочетания всех букв или всех цифр. Но как создать все сочетания элементов матрицы, в которой заранее неизвестна размерность, не углубляясь в Иосифа Романовского и его «Дискретный Анализ», такого материала я не нашел, поэтому и решил написать его здесь. Вдруг кому-то понадобится.

Почему Office, Excel, Visual Basic и не ООП? Я уже частично ответил на эти вопросы выше. Еще могу сказать, что такой выбор продиктован спецификой компании, для которой написан данный алгоритм и тем, что Office это основное ПО, которым пользуются все менеджеры по исследованиям в нашей компании.

Подобная задача чисто прикладная, возникающая постоянно при использовании одного из методов анализа данных.

Дано:

1. На листе «data» находится матрица неопределенной размерности, с неизвестным количеством элементов.
2. Длина каждого столбца матрицы (т.е. количество элементов в столбце) заранее не известна.
3. Длина столбца N с высокой долей вероятности не совпадает с длиной столбца N+1 и длиной столбца N-1.
4. Известно, что длина определенного столбца уже сформированной матрицы не меняется со временем.
5. Известно, что длина строки матрицы всегда одинаковая.
6. Матрица представлена в таблице Эксель в таком виде, что каждому элементу матрицы соответствует одна ячейка со значением элемента. Назовем такую матрицу «матрица начальных условий».

Задача: создавать на листе «res» все варианты сочетаний элементов матрицы начальных условий друг с другом. Одно из значений матрицы не должно повторятся более X раз.

Ну и сам алгоритм, это работающий, протестированный на Excell 2010 скрипт, который я попытался написать максимально просто и понятно:

Dim RangeArray() As Integer
Dim PositionArray() As Integer
Dim ResultArray() As Integer
MaxCombination = 3 ' максимальное количество сочетаний.
PresentValue = 1 ' Значение, которое должно быть в сочетании, будем проверять, что элемент матрицы начальных условий равен этому значению.
MaxYSize = 0 ' Определение нижней границы диапазона значений.
IterationCounter = 1 ' Адрес строки для сгенерированной комбинации на листе res.
CombinationCounter = 0 ' Подсчёт количества сочетаний в сгенерированной комбинации.
MaxIterationCoutner = 1 ' Максимально возможное количество комбинаций для  текущей итерации.
PreviousIterationCounter = 0 ' количество комбинаций для предыдущей итерации, чтобы убрать дубли.

WorkAreaXSize = Selection.Columns.Count 'Вычисляется длинна матрицы начальных условий.
ReDim RangeArray(WorkAreaXSize)
ReDim PositionArray(WorkAreaXSize + 1)
ReDim ResultArray(WorkAreaXSize)
RangeArray(0) = 1 ' На всякий случай. Данный элемент не используется для соответствия индексов массива и номеров ячеек Экселя

For Each Column In Selection.Columns ' Определяем в массив RangeArray, сколько элементов содержит матрица начальных условий в каждом столбце.

    Column.SpecialCells(xlCellTypeConstants).Select
    WorkAreaYSize = Selection.Cells.Count
    If WorkAreaYSize > MaxYSize Then
        MaxYSize = WorkAreaYSize
    End If
    RangeArray(Column.Column) = WorkAreaYSize
    
Next ' занесли длину каждой колонки в массив RangeArray

Range(Cells(1, 1), Cells(MaxYSize, WorkAreaXSize)).Select
ValueArray = Selection ' Это массив значений, которые надо перебрать. Неважно, что захватываются пустые ячейки, их адреса не попадут в массив PositionArray потому, что в RangeArray указан предел, после которого значения в массиве не используются.


' Создаём массив начальной позиции, Это адрес, откуда брать значения в матрице начальных условий. Значения массива -  клетка, номер элемента массива - строка.

    For i = 1 To WorkAreaXSize
        PositionArray(i) = 1
    Next i






    For i = 1 To WorkAreaXSize  'Сколько столбцов, столько итераций, один тик значения i назовём итерацией.
    
    For e = 1 To i ' Вычисляем максимальное количество комбинаций для данной итерации, как произведение кол-ва колонок на длину каждого столбца.
    
        MaxIterationCoutner = MaxIterationCoutner * RangeArray(e) ' Количество сочетаний всех вариантов в начальной матрице условий задачи равное произведению количества элементов каждого её столбца.
        
    Next e
    
    For y = 1 To MaxIterationCoutner 'Подставляем в финальный массив ResultArray() значения по адресу из  PositionArray()
        If PreviousIterationCounter < y Then  ' При следующем проходе не должны повторятся итерации из предыдущего, чтобы не было дублей.
            For j = 1 To WorkAreaXSize
                ResultArray(j) = ValueArray(PositionArray(j), j) 'Подставляем в финальный массив ResultArray() значения по адресу из  PositionArray()
                If ResultArray(j) = PresentValue Then
                    CombinationCounter = CombinationCounter + 1 '  считаем количество сочетаний значения PresentValue, которые не должны повторятся больше чем MaxCombination раз
                End If
        

            Next j ' имеем ResultArray(), заполненный значениями
            
        
        ' сохранить ResultArray() на лист res в строку с адресом IterationCounter если он подходит по условиям задачи
            If CombinationCounter <= MaxCombination Then
                
                For d = 1 To WorkAreaXSize
                    Sheets("res").Cells(IterationCounter, d).Value = ResultArray(d)
                    
                Next d
                IterationCounter = IterationCounter + 1 ' Следующий подходящий результат сохранять на следующую строку
            End If
        
            
        
        End If
        
        CombinationCounter = 0 ' обнуляем количество сочетаний. После if на всякий случай.
        
        
        PositionArray(1) = PositionArray(1) + 1 ' Алгоритм определения следующего адреса в PositionArray, откуда брать значения. Прибавляем к первому значению единицу и сдвигаем её до тех пор, пока все предельные условия в RangeArray() будут меньше или равны значениям PositionArray()
        For ErrorCorrections = 1 To WorkAreaXSize
            If PositionArray(ErrorCorrections) > RangeArray(ErrorCorrections) Then
                PositionArray(ErrorCorrections) = 1
                'If IterationCounter <= MaxIterationCoutner Then ' Проверка, чтобы не было ошибки на превышение длинны массива PositionArray при выполнении этого участка кода после финальной итерации. ToDo сделать её корректно, ведь некоторые комбинации выкидываются по условиям, сейчас просто увеличил размер PositionArray на 1, чтобы скрипт не падал с ошибкой после того, как создал последнюю комбинацию.
                PositionArray(ErrorCorrections + 1) = PositionArray(ErrorCorrections + 1) + 1
               ' End If
            End If
        Next ErrorCorrections
        
        
        
    Next y
    
    PreviousIterationCounter = MaxIterationCoutner 'запоминаем, сколько итераций пропустить в следующем тике.
    
    MaxIterationCoutner = 1 'Обнуляем начальные условия для следующей итерации
    For s = 1 To WorkAreaXSize
        PositionArray(s) = 1
    Next s

Next i ' Следующая итерация

Скрипт с макросом и вариантом матрицы начальных условий:

Буду рад любым комментариям и конструктивной критике.