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

Почему 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 ' Следующая итерация

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

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