Option Explicit
Option Base 1Sub Перебор1()Dim x1 As Long, x2 As Long, x3 As Long, x4 As Long, x5 As Long, x6 As Long, x7 As Long
Dim x8 As Long, x9 As Long, x10 As Long, x11 As Long, x12 As Long, x13 As Long, x14 As Long
'Dim n1%, n2%, n3%, n4%, n5%, n6%, n7%, n8%, n9%, n10%, n11%, n12%, n13%, n14%
Dim N(1 To 14) As Integer, i As Integer
Dim rng As Range
Dim Arr(), tarr()
Dim s As String, a As Long, RR As DoubleSet rng = Range("A3:N500")
Arr = rng: 'a = 1With ActiveSheet
    RR = 1
    For i = 1 To 14
    N(i) = .Cells(Rows.Count, i).End(xlUp).Row - 2
    If N(i) = 0 Then N(i) = 1
    RR = RR * N(i)
    Next
'    n1 = .Cells(Rows.Count, 1).End(xlUp).Row - 2
'    n2 = .Cells(Rows.Count, 2).End(xlUp).Row - 2
'    n3 = .Cells(Rows.Count, 3).End(xlUp).Row - 2
'    n4 = .Cells(Rows.Count, 4).End(xlUp).Row - 2
'    n5 = .Cells(Rows.Count, 5).End(xlUp).Row - 2
'    n6 = .Cells(Rows.Count, 6).End(xlUp).Row - 2
'    n7 = .Cells(Rows.Count, 7).End(xlUp).Row - 2
'    n8 = .Cells(Rows.Count, 8).End(xlUp).Row - 2
'    n9 = .Cells(Rows.Count, 9).End(xlUp).Row - 2
'    n10 = .Cells(Rows.Count, 10).End(xlUp).Row - 2
'    n11 = .Cells(Rows.Count, 11).End(xlUp).Row - 2
'    n12 = .Cells(Rows.Count, 12).End(xlUp).Row - 2
'    n13 = .Cells(Rows.Count, 13).End(xlUp).Row - 2
'    n14 = .Cells(Rows.Count, 14).End(xlUp).Row - 2
End With'If n1 = 0 Then n1 = 1
'If n2 = 0 Then n2 = 1
'If n3 = 0 Then n3 = 1
'If n4 = 0 Then n4 = 1
'If n5 = 0 Then n5 = 1
'If n6 = 0 Then n6 = 1
'If n7 = 0 Then n7 = 1
'If n8 = 0 Then n8 = 1
'If n9 = 0 Then n9 = 1
'If n10 = 0 Then n10 = 1
'If n11 = 0 Then n11 = 1
'If n12 = 0 Then n12 = 1
'If n13 = 0 Then n13 = 1
'If n14 = 0 Then n14 = 1
'RR = n1 * n2 * n3 * n4 * n5 * n6 * n7: RR = RR * n8 * n9 * n10 * n11 * n12 * n13 * n14ReDim tarr(RR, 1)Call FillLevel(N, Arr, 1, "", tarr, 0)
'    For x1 = 1 To n1
'     For x2 = 1 To n2
'      For x3 = 1 To n3
'       For x4 = 1 To n4
'        For x5 = 1 To n5
'         For x6 = 1 To n6
'          For x7 = 1 To n7
'           For x8 = 1 To n8
'            For x9 = 1 To n9
'             For x10 = 1 To n10
'              For x11 = 1 To n11
'               For x12 = 1 To n12
'                For x13 = 1 To n13
'                 For x14 = 1 To n14
'                  tarr(a, 1) = Arr(x1, 1) & Arr(x2, 2) & Arr(x3, 3) & Arr(x4, 4) & Arr(x5, 5) & Arr(x6, 6) & Arr(x7, 7) & _
'                  Arr(x8, 8) & Arr(x9, 9) & Arr(x10, 10) & Arr(x11, 11) & Arr(x12, 12) & Arr(x13, 13) & Arr(x14, 14)
'                  a = a + 1
'                 Next x14
'                Next x13
'               Next x12
'              Next x11
'             Next x10
'            Next x9
'           Next x8
'          Next x7
'         Next x6
'        Next x5
'       Next x4
'      Next x3
'     Next x2
'    Next x1
    
ThisWorkbook.Sheets("Список значений").Range("A:A").ClearContents
ThisWorkbook.Sheets("Список значений").Range("A1:A" & RR).Value = tarr
ThisWorkbook.Sheets("Список значений").Activate
Erase Arr: Erase tarrEnd SubSub FillLevel(N, Arr, ByVal Level, ByVal Code As String, tarr, J)
    Dim i  As Integer
    For i = 1 To N(Level)
        If Level = UBound(N) Then
            J = J + 1
            tarr(J, 1) = Code & Arr(i, Level)
        Else
            Call FillLevel(N, Arr, Level + 1, Code & Arr(i, Level), tarr, J)
        End If
    Next
End Sub