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

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

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

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

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

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

Cells(1, 3).Resize(UBound(ArrX) + 1, B).Value = Rslt

End Sub

Function RioDTB(X As Long, Y As Byte) As String

'Function for Rio_Combinations sub

Dim TwoX(30) As Long
Dim i As Long

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