VBA Offset в цикле - вечно бегать

Question

Я новичок в программировании, и я подумал, что VBA - это хорошее место для начала, так как я много работаю в Excel.

Я создал макрос, который получает целое число от вводаbox (я использовал 2, 3 и 4 для тестирования), и он создает набор 4-уровневой иерархии этого числа;например, если ввести «2», то получится

1.0.0.0
1.0.0.1
1.0.0.2
1.0.1.0
1.0.1.1
1.0.1.2 etc.

Я заставил макрос работать так, как задумано, но для его запуска требуется вечность.Я думаю, что смещения внутри циклов замедляют его.У кого-нибудь есть предложения, чтобы ускорить это?Любые общие отзывы также приветствуются.

Sub Tiers()

'Input Box
Dim Square As Integer
Square = InputBox("Enter Number of Tiers")
Range("f5").Select
Selection.Value = 0
 With Application
    .ScreenUpdating = False
End With

'Rows down
Dim g As Integer
Dim h As Integer
Dim i As Integer
Dim j As Integer

'Start For loops
For g = 1 To Square
    For h = 0 To Square
        For i = 0 To Square
            For j = 0 To Square

                'calculate offsets and place values of loop variables
                Dim step As Long
                step = ((g - 1) * (Square + 1) ^ 3 - 1 + (h * (Square + 1) ^ 2) + Square * i + i + j + 1)
                Selection.Offset(step, 0).Value = j
                Selection.Offset(step, -1).Value = i
                Selection.Offset(step, -2).Value = h
                Selection.Offset(step, -3).Value = g


            Next j
        Next i
    Next h
Next g

With Application
    .ScreenUpdating = True
End With

End Sub

Спасибо

Answer 1

В дополнение к моему комментарию под вашим постом, цикл и запись на листы, подобные этому, будут слишком медленными.Записать в массив, а затем записать массив на лист.Это было в мгновение ока.

Это то, что вы пытаетесь?

Sub Sample()
    Dim TempArray() As Long
    Dim n As Long
    Dim g As Long, h As Long, i As Long, j As Long
    Dim reponse As Variant

    '~~> Accept only numbers
    reponse = Application.InputBox(Prompt:="Enter Number of Tiers", Type:=1)

    If reponse <> False Then
        For g = 1 To reponse
            For h = 0 To reponse
                For i = 0 To reponse
                    For j = 0 To reponse
                        n = n + 1
                    Next j
                Next i
            Next h
        Next g

        ReDim Preserve TempArray(1 To n, 1 To 4)
        n = 1

        For g = 1 To reponse
            For h = 0 To reponse
                For i = 0 To reponse
                    For j = 0 To reponse
                        TempArray(n, 1) = g
                        TempArray(n, 2) = h
                        TempArray(n, 3) = i
                        TempArray(n, 4) = j
                        n = n + 1
                    Next j
                Next i
            Next h
        Next g

        '~~> Replace this with the relevant sheet
        Sheet1.Range("A1").Resize(UBound(TempArray), 4).Value = TempArray
    End If
End Sub

Снимок экрана :

Answer 2

Расчет step кажется излишним:

step = ((g - 1) * (Square + 1) ^ 3 - 1 + (h * (Square + 1) ^ 2) + Square * i + i + j + 1)

Попробуйте следующее:

Sub Tiers()

'Input Box
Dim Square As Long
Square = InputBox("Enter Number of Tiers")
With Application
    .ScreenUpdating = False
End With

'Rows down
Dim g As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim step As Long

step = 1

For g = 1 To Square
    For h = 0 To Square
        For i = 0 To Square
            For j = 0 To Square
                Range("F5").Offset(step, 0).Value = j
                Range("F5").Offset(step, -1).Value = i
                Range("F5").Offset(step, -2).Value = h
                Range("F5").Offset(step, -3).Value = g
                step = step + 1
            Next j
        Next i
    Next h
Next g

With Application
    .ScreenUpdating = True
End With

End Sub