Как изменить выходные данные назначения, когда код VBA достигает строки 1 048 576

Question

Я пытаюсь запустить код, который показывает все возможные комбинации, когда выпадают 8 кубиков. Проблема в том, что существует почти 1,7 миллиона комбинаций, а в Excel всего 1 048 576 строк, поэтому VBA продолжает выдавать мне ошибку (ошибка времени выполнения «1004»: сбой метода «Смещение» объекта «Диапазон»). Как я могу исправить эту проблему?

Вот мой код:

Sub combinations()

Dim c1() As Variant
Dim c2() As Variant
Dim c3() As Variant
Dim c4() As Variant
Dim c5() As Variant
Dim c6() As Variant
Dim c7() As Variant
Dim c8() As Variant
Dim out() As Variant
Dim j, k, l, m, n, o, p, q, r As Long


Dim col1 As Range
Dim col2 As Range
Dim col3 As Range
Dim col4 As Range
Dim col5 As Range
Dim col6 As Range
Dim col7 As Range
Dim col8 As Range
Dim out1 As Range


Set col1 = Range("A1:A6")
Set col2 = Range("B1:B6")
Set col3 = Range("C1:C6")
Set col4 = Range("D1:D6")
Set col5 = Range("E1:E6")
Set col6 = Range("F1:F6")
Set col7 = Range("G1:G6")
Set col8 = Range("H1:H6")

c1 = col1
c2 = col2
c3 = col3
c4 = col4
c5 = col5
c6 = col6
c7 = col7
c8 = col8

Set out1 = Range("J2", Range("Q2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4) * UBound(c5) * UBound(c6) * UBound(c7) * UBound(c8)))
out = out1

j = 1
k = 1
l = 1
m = 1
n = 1
o = 1
p = 1
q = 1
r = 1


Do While j <= UBound(c1)
    Do While k <= UBound(c2)
        Do While l <= UBound(c3)
            Do While m <= UBound(c4)
                Do While n <= UBound(c5)
                    Do While o <= UBound(c6)
                        Do While p <= UBound(c7)
                            Do While q <= UBound(c8)
                            out(r, 1) = c1(j, 1)
                            out(r, 2) = c2(k, 1)
                            out(r, 3) = c3(l, 1)
                            out(r, 4) = c4(m, 1)
                            out(r, 5) = c5(n, 1)
                            out(r, 6) = c6(o, 1)
                            out(r, 7) = c7(p, 1)
                            out(r, 8) = c8(q, 1)
                            r = r + 1
                            q = q + 1
                        Loop
                        q = 1
                        p = p + 1
                    Loop
                    p = 1
                    o = o + 1
                Loop
                o = 1
                n = n + 1
            Loop
            n = 1
            m = m + 1
        Loop
        m = 1
        l = l + 1
    Loop
    l = 1
    k = k + 1
Loop
k = 1
j = j + 1
out = out1
Loop

out1.Value = out
End Sub

Как добавить в L oop, что, когда он достигает строки 1 048 576, он должен начать запускать комбинации в другой набор столбцов? В идеале я хотел бы, чтобы он запустил код в столбцах T2 - AA2 после заполнения J2 - Q2.

Answer 1

Проверено:

Sub combinations()

    Const max_rows As Long = 1000000

    Dim c(1 To 8) As Variant
    Dim r As Long
    Dim i As Long, totRows As Long, out()
    Dim x1 As Long, x2 As Long, x3 As Long, x4 As Long
    Dim x5 As Long, x6 As Long, x7 As Long, x8 As Long
    Dim rngOut As Range

    totRows = 1
    For i = 1 To 8
        c(i) = Range("A1:A6").Offset(0, i - 1).Value
        totRows = totRows * UBound(c(i), 1)
    Next i

    Debug.Print totRows

    ReDim out(1 To max_rows, 1 To 8)
    Set rngOut = Range("A8")
    r = 1
    For x1 = 1 To UBound(c(1), 1)
    For x2 = 1 To UBound(c(2), 1)
    For x3 = 1 To UBound(c(3), 1)
    For x4 = 1 To UBound(c(4), 1)
    For x5 = 1 To UBound(c(5), 1)
    For x6 = 1 To UBound(c(6), 1)
    For x7 = 1 To UBound(c(7), 1)
    For x8 = 1 To UBound(c(8), 1)
        out(r, 1) = c(1)(x1, 1)
        out(r, 2) = c(2)(x2, 1)
        out(r, 3) = c(3)(x3, 1)
        out(r, 4) = c(4)(x4, 1)
        out(r, 5) = c(5)(x5, 1)
        out(r, 6) = c(6)(x6, 1)
        out(r, 7) = c(7)(x7, 1)
        out(r, 8) = c(8)(x8, 1)
        If r = max_rows Then
            'hit row limit: output and move over
            rngOut.Resize(max_rows, 8).Value = out
            Set rngOut = rngOut.Offset(0, 10)
            ReDim out(1 To max_rows, 1 To 8)
            r = 0
        End If
        r = r + 1
    Next x8
    Next x7
    Next x6
    Next x5
    Next x4
    Next x3
    Next x2
    Next x1

    rngOut.Resize(max_rows, 8).Value = out

End Sub

Answer 2

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

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

Sub testCombinations_()
 '.......
 Dim out2 As Range, outBis As Variant, acceptR As Double
 Const maxR As Long = 1048574
 acceptR = UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4) * UBound(c5) * UBound(c6) * UBound(c7) * UBound(c8)
 If acceptR > maxR Then
    Set out1 = Range("J2", Range("Q2").Offset(maxR))
    Set out2 = Range("T2", Range("AA2").Offset(acceptR - maxR))
    out = out1.value
    outBis = out2.value ' only for easy array dimensioning
 Else
    Set out1 = Range("J2", Range("Q2").Offset(acceptR))
    out = out1.value
 End If
 'follow your code...
 '..........
            Do While q <= UBound(c8)
                If r <= maxR Then
                    out(r, 1) = c1(j, 1)
                    out(r, 2) = c2(k, 1)
                    out(r, 3) = c3(L, 1)
                    out(r, 4) = c4(m, 1)
                    out(r, 5) = c5(n, 1)
                    out(r, 6) = c6(o, 1)
                    out(r, 7) = c7(p, 1)
                    out(r, 8) = c8(q, 1)
                    r = r + 1
                    q = q + 1
                    If r = maxR Then r = 1
                 Else
                    outBis(r, 1) = c1(j, 1)
                    outBis(r, 2) = c2(k, 1)
                    outBis(r, 3) = c3(L, 1)
                    outBis(r, 4) = c4(m, 1)
                    outBis(r, 5) = c5(n, 1)
                    outBis(r, 6) = c6(o, 1)
                    outBis(r, 7) = c7(p, 1)
                    outBis(r, 8) = c8(q, 1)
                    r = r + 1
                    q = q + 1
                 End If
            Loop
    '.........
    out1.value = out
    If UBound(outBis) > 1 Then out2.value = outBis
End Sub

Нравится общее замечание: Dim j, k, l, m, n, o, p, q, r As Long затемнит все перечисления As Variant и только последнее As Long. И трудно следовать такому длинному вертикальному коду ... Я бы использовал: j = 1: k = 1: l = 1:... и так далее для всех вертикальных «расположений». Вертикальный способ хорош и делает код более понятным только для небольшого числа переменных. Конечно, это не обязательно ...

Код, конечно, не проверен, и, возможно, его необходимо улучшить или исправить ...