Медленный макрос

[Sotrom]

Господа! Подскажите, пожалуйста, начинающему как ускорить выполнение макроса. Работает очень медленно, более 30 минут уходит на его выполнение.

Sub Monte_Karlo()
'
' Monte_Karlo Макрос

MasageOK_NO = MsgBox("Сейчас начнется расчет 5000 значений выбранных показателей модели методом Монте-Карло. На расчет потребуется несколько минут. Продолжить?", vbYesNo, "МОНТЕ-КАРЛО")
If MasageOK_NO = 7 Then GoTo Конец
Application.ScreenUpdating = False
Dim x As Variant
For x = 20 To 5019
Range(Cells(x, 2), Cells(x, 7)).Select
Selection.Copy
Range("B19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("H19").Select
    Application.CutCopyMode = False
    Selection.Copy
Range(Cells(x, 8), Cells(x, 8)).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("I19").Select
    Application.CutCopyMode = False
    Selection.Copy
Range(Cells(x, 9), Cells(x, 9)).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Next x
Range("B19").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "1"
    Range("C19").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("D19").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("E19").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("F19").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("G19").Select
    ActiveCell.FormulaR1C1 = "1"
Конец_расчета:
    MsgBox "Расчет окончен!"
Application.ScreenUpdating = True
Exit Sub
Конец:
MsgBox "Расчет прерван", , "МОНТЕ-КАРЛО"

End Sub

[Hugo121]

Секунда:

Sub Monte_Karlo2()
'
' Monte_Karlo Макрос

MasageOK_NO = MsgBox("Сейчас начнется расчет 5000 значений выбранных показателей модели методом Монте-Карло. На расчет потребуется несколько минут. Продолжить?", vbYesNo, "МОНТЕ-КАРЛО")
If MasageOK_NO = 7 Then GoTo Конец
Application.ScreenUpdating = False
Dim x As Variant
'Dim t: t = Timer
For x = 20 To 5019
Range("B19") = Range(Cells(x, 2), Cells(x, 7))
Cells(x, 8) = Range("H19")
Range(Cells(x, 9), Cells(x, 9)) = Range("I19")
Next x
[b19:g19] = 1
Конец_расчета:
'Debug.Print Timer - t
MsgBox "Расчет окончен!"
Application.ScreenUpdating = True
Exit Sub
Конец:
MsgBox "Расчет прерван", , "МОНТЕ-КАРЛО"

End Sub

Но у Вас вероятно ещё тормозит из-за пересчёта других формул, которые всё и считают.

[Sotrom]

-> Hugo121
Спасибо за отклик, но что-то не то с Вашим кодом. Проверил, он делает немного не то, что был у меня

[Hugo121]

Ну он ячейки не выделяет
А так вроде то-же должен делать.
Но это конечно на рабочем файле нужно смотреть, у меня его нет.

[RAN.]

Исправьте
Range("B19").Resize(, 6) = Range(Cells(x, 2), Cells(x, 7))

[Hugo121]

Да, точно, спасибо, упустил:

For x = 20 To 5019
Range("B19").Resize(, 6) = Range(Cells(x, 2), Cells(x, 7))
Cells(x, 8) = Range("H19")
Cells(x, 9) = Range("I19")
Next x

Хотя и тут ещё есть что сократить

[IgorGO]

а так подходит:

Sub Monte_Karlo2()
'
' Monte_Karlo Макрос

MasageOK_NO = MsgBox("Сейчас начнется расчет 5000 значений выбранных показателей модели методом Монте-Карло. На расчет потребуется несколько минут. Продолжить?", vbYesNo, "МОНТЕ-КАРЛО")
If MasageOK_NO = 7 Then GoTo Конец
Application.ScreenUpdating = False
Dim x As Variant
'Dim t: t = Timer
For x = 20 To 5019
Range(Cells(x, 2), Cells(x, 7)).copy
[B19].PasteSpecial Paste:=xlPasteValues
Cells(x, 8) = [H19]
Cells(x, 9) = [I19]
Next x
[b19:g19] = 1
Конец_расчета:
'Debug.Print Timer - t
MsgBox "Расчет окончен!"
Application.ScreenUpdating = True
Exit Sub
Конец:
MsgBox "Расчет прерван", , "МОНТЕ-КАРЛО"
End Sub

[Sotrom]

->Hugo121
Не работает. Все искомые значения, которые запоминаются, получаются одинаковыми.

Привожу в двух словах как должно работать.
Есть 8 столбцов. Из них 6 первых столбцов это переменные, и еще 2 - это значения которые ищем.
Первая строчка (ячейки B19-I19) представляет собой:

1 1 1 1 1 1 25 150

25 и 150 это искомые значения.

Далее цикл:
Значения случайных числе (которые я заранее сгенерировал) из ячеек В20 - G20 подставляются в ячейки, где сейчас единички (B19 - G19). Искомые значения пересчитываются (завязаны на весь расчетный файл) и их значения из ячеек H19 и I19 копируются в сроку 20, т.е. в H20 и I20.
Далее цикл повторяется. Из сроки 21 значения попадают в 19 сроку, а искомые значения из 19 сроки попадают в 21 строку и т.д. 5000 раз.

В конце в ячейках B19-G19 подставляются значения с 1, чтобы вернуть файл в исходное состояние. Но это у всех получилось

->IgorGo
Ваш код почти работает, но значения периодически смещаются с нужной строчки... Не понимаю почему. Только он не столь компактен как у Hugo121

[Sotrom]

Hugo121 прав, что вероятнее всего макрос тормозит из за всего файла... Там расчет делается по нескольким десяткам тысяч ячеек.
Но очень хочется, чтобы сам код не выполнял функцию "бутылочного горлышка".

[Hugo121]

Нда, так и есть, без примера код писать...
Первое копирование так идёт, через массив, иначе (и через Resize тоже) не работает:

Dim a
...
For x = 20 To 5019
a = Range(Cells(x, 2), Cells(x, 7))
[B19:G19] = a

Можно было ещё приравнивать ячейки по-одной, благо их немного...
Ну а торомоза из-за формул, этот код за секунду отрабатывает.