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

Question

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

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

Как я могу исправить эту проблему?

Вот весь мой код:

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).Offset(0, Z) = c1(j, 1)
                            out(r, 2).Offset(0, Z) = c2(k, 1)
                            out(r, 3).Offset(0, Z) = c3(l, 1)
                            out(r, 4).Offset(0, Z) = c4(m, 1)
                            out(r, 5).Offset(0, Z) = c5(n, 1)
                            out(r, 6).Offset(0, Z) = c6(o, 1)
                            out(r, 7).Offset(0, Z) = c7(p, 1)
                            out(r, 8).Offset(0, Z) = c8(q, 1)
                            r = r + 1
                            If r > 1000000 Then
                            r = 1: Z = 10
                            End If
                            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

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

Answer 1

Попробуйте этот код, пожалуйста. Я изначально пытался ответить только на ваш вопрос. Теперь я также немного адаптировал ваш код. Пожалуйста, попробуйте для диапазонов, которые вы показали нам в вопросе. Если вы увеличите их, код должен быть адаптирован (не очень сложен), чтобы также использовать другие массивы и, возможно, удалять содержимое массивов в некоторых файлах .csv. Пожалуйста, проверьте это как есть и подтвердите, что это то, чего вы хотели достичь.

Sub combinations()
Dim c1() As Variant, c2() As Variant, c3() As Variant, c4() As Variant
Dim c5() As Variant, c6() As Variant, c7() As Variant, c8() As Variant

Dim j As Long, k As Long, l As Long, m As Long, n As Long
Dim o As Long, p As Long, q As Long, r As Long

Dim col1 As Range, col2 As Range, col3 As Range, col4 As Range
Dim col5 As Range, col6 As Range, col7 As Range, col8 As Range
Dim out1 As Range, out() As Variant

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

'___________________________________________________________________________
 Dim out2 As Range, outBis As Variant, acceptR As Double, boolNext 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 dimensstoning
 Else
    Set out1 = Range("J2", Range("Q2").Offset(acceptR))
    out = out1.value
 End If
 '_______________________________________________________________________________
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)
                                If Not boolNext 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 boolNext = True : 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
                            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
Loop

out1.value = out
If UBound(outBis) > 1 Then out2.value = outBis
End Sub

Answer 2

Если вам действительно нужно сделать это с помощью Excel, я предложу вам свою идею, и вы скажете мне, возможно ли это с вашим проектом.

Основная интуиция c заключается в том, что 6 в степени 4, очевидно, более управляемы, чем 6 в степени 8. Поэтому я бы разделил 8 кубиков на две. Первые четыре будут «Фиксированной частью» (красный на рисунке), а вторые четыре будут «Мобильной частью» (серый и белый на рисунке). Каждый ряд даст вам все возможные комбинации каждой «Фиксированной части» с остальными четырьмя кубиками. Первые четыре столбца предоставят вам все возможные комбинации «Фиксированной части».

В результате у вас будет следующая таблица из 1296 строк и 5184 = (1296 * 4) столбцов:

Код :

Sub EightDiceCombinations()
Dim FourDiceArray()
Dim i, j, k, l As Long
Dim FxNRow As Long
Dim MbNRow, MbNCol As Long

FxNRow = 1
MbNCol = 5

For i = 1 To 6
    For j = 1 To 6
        For k = 1 To 6
            For l = 1 To 6

                FourDiceArray = Array(i, j, k, l)
                'MsgBox Join(FourDiceArray, " ")__TEST

                'Fill Fixed Part
                ActiveSheet.Range(Cells(FxNRow, 1), Cells(FxNRow, 4)).Value = FourDiceArray

                'Fill Mobile Part
                For MbNRow = 1 To 1296 '(6 to the power of 4)
                ActiveSheet.Range(Cells(MbNRow, MbNCol), Cells(MbNRow, MbNCol + 3)).Value = FourDiceArray
                Next MbNRow

                MbNCol = MbNCol + 4
                FxNRow = FxNRow + 1

            Next l
        Next k
    Next j
Next i


End Sub

В примечании вы всегда можете получить Комбинация EightDice с набором случайных функций: Random («Фиксированная часть») и Random («Мобильная часть»).

Надеюсь, это решение поможет вам.