Очень долгое выполнение кода

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Очень долгое выполнение кода (Макросы/Sub)

Markovich

Дата: Вторник, 23.02.2021, 19:28 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 50

Репутация: 0 ±

Замечаний: 0% ±

Excel 2019

Доброго времени суток уважаемые форумчане! Делаю первые робкие шаги в написании макросов и на подводные камни наталкиваюсь на каждом шагу. Решаю следующую задачу: есть форма, в нее из разных источников копируются диапазоны строк, в определенных ячейках есть формулы, которые либо несовместимы с текущей версией формы, либо при вставке получаются ненужные ссылки на источник, но так же в этих ячейках могут быть и значения (которые не рассчитываются формулами, а вводятся вручную). Написал макрос, который в определенные ячейки, содержащие формулы, либо пустые перезаписывает формулы с эталона. Количество строк в таблице варьируется от 150 до >3000. Макрос работает, но проблема в том что жутко тормозит, когда количество строк 150 макрос выполняется около 45 секунд, а вот когда 3000 строк, то через час я так и не дождался окончания операции и завершил excel через диспетчер задач (так и не знаю завершился бы процесс или excel завис). Выключением обновления экрана и переводом в ручной пересчет мои попытки оптимизировать закончились. Подскажите, пожалуйста, можно ли как то оптимизировать макрос?
[vba]

Код

Sub RecoveryFormula_Partly()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    With Sheets("Вводные данные")
        For i = 11 To [Full]
        Worksheets("service1").Cells(1, 1).Copy .Cells(i, 1)
            If Cells(i, 6).HasFormula Or Cells(i, 6) = "" Then
                Worksheets("service1").Cells(1, 6).Copy .Cells(i, 6)
            End If
        Worksheets("service1").Cells(1, 12).Copy .Cells(i, 12)
            If Cells(i, 13).HasFormula Or Cells(i, 13) = "" Then
                Worksheets("service1").Cells(1, 13).Copy .Cells(i, 13)
            End If
            If Cells(i, 14).HasFormula Or Cells(i, 14) = "" Then
                Worksheets("service1").Cells(1, 14).Copy .Cells(i, 14)
            End If
            If Cells(i, 15).HasFormula Or Cells(i, 15) = "" Then
                Worksheets("service1").Cells(1, 15).Copy .Cells(i, 15)
            End If
            If Cells(i, 16).HasFormula Or Cells(i, 16) = "" Then
                Worksheets("service1").Cells(1, 16).Copy .Cells(i, 16)
            End If
            If Cells(i, 17).HasFormula Or Cells(i, 17) = "" Then
                Worksheets("service1").Cells(1, 17).Copy .Cells(i, 17)
            End If
        Worksheets("service1").Cells(1, 18).Copy .Cells(i, 18)
            If Cells(i, 19).HasFormula Or Cells(i, 19) = "" Then
                Worksheets("service1").Cells(1, 19).Copy .Cells(i, 19)
            End If
            If Cells(i, 20).HasFormula Or Cells(i, 20) = "" Then
                Worksheets("service1").Cells(1, 20).Copy .Cells(i, 20)
            End If
        Worksheets("service1").Cells(1, 21).Resize(1, 2).Copy .Cells(i, 21).Resize(1, 2)
            If Cells(i, 23).HasFormula Or Cells(i, 23) = "" Then
                Worksheets("service1").Cells(1, 23).Copy .Cells(i, 23)
            End If
            If Cells(i, 24).HasFormula Or Cells(i, 24) = "" Then
                Worksheets("service1").Cells(1, 24).Copy .Cells(i, 24)
            End If
            If Cells(i, 25).HasFormula Or Cells(i, 25) = "" Then
                Worksheets("service1").Cells(1, 25).Copy .Cells(i, 25)
            End If
        Worksheets("service1").Cells(1, 26).Copy .Cells(i, 26)
            If Cells(i, 27).HasFormula Or Cells(i, 27) = "" Then
                Worksheets("service1").Cells(1, 27).Copy .Cells(i, 27)
            End If
            If Cells(i, 28).HasFormula Or Cells(i, 28) = "" Then
                Worksheets("service1").Cells(1, 28).Copy .Cells(i, 28)
            End If
            If Cells(i, 29).HasFormula Or Cells(i, 29) = "" Then
                Worksheets("service1").Cells(1, 29).Copy .Cells(i, 29)
            End If
            If Cells(i, 33).HasFormula Or Cells(i, 33) = "" Then
                Worksheets("service1").Cells(1, 33).Copy .Cells(i, 33)
            End If
        Worksheets("service1").Cells(1, 34).Resize(1, 2).Copy .Cells(i, 34).Resize(1, 2)
            If Cells(i, 36).HasFormula Or Cells(i, 36) = "" Then
                Worksheets("service1").Cells(1, 36).Copy .Cells(i, 36)
            End If
        Next
    End With
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[/vba]
Спасибо.

Код

[/vba]
Спасибо.Markovich

Ответить

СообщениеДоброго времени суток уважаемые форумчане! Делаю первые робкие шаги в написании макросов и на подводные камни наталкиваюсь на каждом шагу. Решаю следующую задачу: есть форма, в нее из разных источников копируются диапазоны строк, в определенных ячейках есть формулы, которые либо несовместимы с текущей версией формы, либо при вставке получаются ненужные ссылки на источник, но так же в этих ячейках могут быть и значения (которые не рассчитываются формулами, а вводятся вручную). Написал макрос, который в определенные ячейки, содержащие формулы, либо пустые перезаписывает формулы с эталона. Количество строк в таблице варьируется от 150 до >3000. Макрос работает, но проблема в том что жутко тормозит, когда количество строк 150 макрос выполняется около 45 секунд, а вот когда 3000 строк, то через час я так и не дождался окончания операции и завершил excel через диспетчер задач (так и не знаю завершился бы процесс или excel завис). Выключением обновления экрана и переводом в ручной пересчет мои попытки оптимизировать закончились. Подскажите, пожалуйста, можно ли как то оптимизировать макрос?
[vba]

Код

[/vba]
Спасибо.

Автор - Markovich
Дата добавления - 23.02.2021 в 19:28

Апострофф

Дата: Вторник, 23.02.2021, 20:06 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 445

Репутация: 123 ±

Замечаний: 0% ±

Excel 1997

Markovich, вместо этого

Цитата Markovich, 23.02.2021 в 19:28, в сообщении № 1 ()

[vba]

Код

Worksheets("service1").Cells(1, 1).Copy .Cells(i, 1)

[/vba]

попробуйте это
[vba]

Код

.Cells(i, 1).FORMULA = Worksheets("service1").Cells(1, 1).FORMULA

[/vba]
К тому же присваивать можно не поячеечно и в цикле, а целыми диапазонами.
Думаю, это многократно повысить скорость.

Ответить

bmv98rus

Дата: Вторник, 23.02.2021, 20:14 | Сообщение № 3

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4106

Репутация: 768 ±

Замечаний: 0% ±

Excel 2013/2016

Markovich, что бросается сразу в глаза, так это то что вы работаете с 3 листами
1. With Sheets("Вводные данные")
2. Worksheets("service1")
3. и активный лист If Cells(i, 6)
что нужно без примера не понять, но в любом случае лучше или сразу определить листы типа set SServ= Worksheets("service1") ...

Цитата Апострофф, 23.02.2021 в 20:06, в сообщении № 2 ()

попробуйте это

не факт, может нужно копировать и формат, но это относится к вопросу не понятно с чем работает и что нужно получить.

~~Замечательный~~ Временно просто медведь ~~, процентов на 20~~.

Сообщение отредактировал bmv98rus - Вторник, 23.02.2021, 20:27

Ответить

Markovich

Дата: Вторник, 23.02.2021, 22:10 | Сообщение № 4

Группа: Пользователи

Ранг: Участник

Сообщений: 50

Репутация: 0 ±

Замечаний: 0% ±

Excel 2019

Апострофф, спасибо. переделал как понял из Вашей рекомендации:
[vba]

Код

.Cells(i, 1).FORMULA = Worksheets("service1").Cells(1, 1).FORMULA

[/vba]
поллучилось:
[vba]

Код

Sub RecoveryFormula_Partly_test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    With Sheets("Вводные данные")
        For i = 11 To [Full]
        .Cells(i, 1).Formula = Worksheets("service1").Cells(1, 1).Formula
            If Cells(i, 6).HasFormula Or Cells(i, 6) = "" Then
                .Cells(i, 6).Formula = Worksheets("service1").Cells(1, 6).Formula
            End If
        .Cells(i, 12).Formula = Worksheets("service1").Cells(1, 12).Formula
            If Cells(i, 13).HasFormula Or Cells(i, 13) = "" Then
                .Cells(i, 13).Formula = Worksheets("service1").Cells(1, 13).Formula
            End If
            If Cells(i, 14).HasFormula Or Cells(i, 14) = "" Then
                .Cells(i, 14).Formula = Worksheets("service1").Cells(1, 14).Formula
            End If
            If Cells(i, 15).HasFormula Or Cells(i, 15) = "" Then
                .Cells(i, 15).Formula = Worksheets("service1").Cells(1, 15).Formula
            End If
            If Cells(i, 16).HasFormula Or Cells(i, 16) = "" Then
                .Cells(i, 16).Formula = Worksheets("service1").Cells(1, 16).Formula
            End If
        Next
    End With
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[/vba]
Макрос стал работать однозначно быстрее, но как то странно... Там где в ячейку копируется формула из эталонной без условия работает четко, а где есть условие, то вылезает кривизна: копирование с эталонна преобразовывается в вид:

Код

=IF(INDEX(service!$AX:$AX,ROW())="","",INDEX(service!$AX:$AX,ROW()))

и формат ячейки становится текстовым, а в оригинале в ячейку должна быть скопирована формула:

Код

=ЕСЛИ(ИНДЕКС(service!$AX:$AX;СТРОКА())="";"";ИНДЕКС(service!$AX:$AX;СТРОКА()))

. В чем может быть ошибка?

Цитата

К тому же присваивать можно не поячеечно и в цикле, а целыми диапазонами.

Извините, я понимаю о чем речь, но не понимаю как реализовать. Можно немного подробнее объяснить?

Апострофф, спасибо. переделал как понял из Вашей рекомендации:
[vba]

Код

.Cells(i, 1).FORMULA = Worksheets("service1").Cells(1, 1).FORMULA

[/vba]
поллучилось:
[vba]

Код

=IF(INDEX(service!$AX:$AX,ROW())="","",INDEX(service!$AX:$AX,ROW()))

и формат ячейки становится текстовым, а в оригинале в ячейку должна быть скопирована формула:

Код

=ЕСЛИ(ИНДЕКС(service!$AX:$AX;СТРОКА())="";"";ИНДЕКС(service!$AX:$AX;СТРОКА()))

. В чем может быть ошибка?

Цитата

К тому же присваивать можно не поячеечно и в цикле, а целыми диапазонами.

Извините, я понимаю о чем речь, но не понимаю как реализовать. Можно немного подробнее объяснить?Markovich

Ответить

СообщениеАпострофф, спасибо. переделал как понял из Вашей рекомендации:
[vba]

Код

.Cells(i, 1).FORMULA = Worksheets("service1").Cells(1, 1).FORMULA

[/vba]
поллучилось:
[vba]

Код

=IF(INDEX(service!$AX:$AX,ROW())="","",INDEX(service!$AX:$AX,ROW()))

и формат ячейки становится текстовым, а в оригинале в ячейку должна быть скопирована формула:

Код

=ЕСЛИ(ИНДЕКС(service!$AX:$AX;СТРОКА())="";"";ИНДЕКС(service!$AX:$AX;СТРОКА()))

. В чем может быть ошибка?

Цитата

К тому же присваивать можно не поячеечно и в цикле, а целыми диапазонами.

Извините, я понимаю о чем речь, но не понимаю как реализовать. Можно немного подробнее объяснить?

Автор - Markovich
Дата добавления - 23.02.2021 в 22:10

Markovich

Дата: Вторник, 23.02.2021, 23:19 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 50

Репутация: 0 ±

Замечаний: 0% ±

Excel 2019

bmv98rus, на самом деле работаю с двумя листами "Вводные данные" и "service1", если получается три листа, значит скривил. Что нужно поправить? Все делаю по аналогии с тем что увидел или подсказали. Понимаю, что нужно учить с нуля, как говорится "учите матчасть", но совсем другая профессия, времени не хватает катастрофически.

Цитата

сразу определить листы типа set SServ= Worksheets("service1")

не совсем понял о чем речь, если не сложно объясните про что речь, изучу вопрос.

Цитата

может нужно копировать и формат

да, формат копировать тоже нужно.
Прилагаю пример. В "Вводные данные" вносится информация и вручную, и из других источников, добавляются, вставляются и удаляются строки, поэтому формулы в ячейках могут искажаться. В белых ячейках формул нет, только вводные данные, в розовых ячейках только формулы (как информационные), в зеленых ячейках формулы, т.е. предлагается какой то расчет, но можно внести значение вручную (если расчет по-умолчанию не устраивает). Все расчеты ведутся на листе "service" (в данном вопросе он не участвует), на листе "service1" находится эталонная строка. Т.о., например, скопировал откуда то строки, в розовых и зеленых ячейках формулы получились кривые, причем в зеленых могут быть значения, которые трогать нельзя. Вот я и заново макросом переписываю все ячейки, где есть формулы, формулами из эталонной строки, не трогая значения. Наверное не самый удачный алгоритм, но постоянно работаю над усовершенствованием. Частично из-за этого и получаются несовместимые источник и приемник при копировании.

Цитата

сразу определить листы типа set SServ= Worksheets("service1")

не совсем понял о чем речь, если не сложно объясните про что речь, изучу вопрос.

Цитата

может нужно копировать и формат

К сообщению приложен файл: 1538274.xls (114.0 Kb)

Сообщение отредактировал Markovich - Вторник, 23.02.2021, 23:22

Ответить

Сообщениеbmv98rus, на самом деле работаю с двумя листами "Вводные данные" и "service1", если получается три листа, значит скривил. Что нужно поправить? Все делаю по аналогии с тем что увидел или подсказали. Понимаю, что нужно учить с нуля, как говорится "учите матчасть", но совсем другая профессия, времени не хватает катастрофически.

Цитата

сразу определить листы типа set SServ= Worksheets("service1")

не совсем понял о чем речь, если не сложно объясните про что речь, изучу вопрос.

Цитата

может нужно копировать и формат

Автор - Markovich
Дата добавления - 23.02.2021 в 23:19

nilem

Дата: Пятница, 26.02.2021, 09:18 | Сообщение № 6

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

Markovich, привет
попробуйте:

[vba]

Код

Sub RecoveryFormula_Partly()
Dim x, i&, tm!, rng As Range
tm = Timer

With Application
    .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Set rng = Sheets("service1").Range("A1:AJ1")

With Sheets("Ââîäíûå äàííûå")
    x = .Range("A11:AJ" & .Cells(Rows.Count, 1).End(xlUp).Row).Formula

    For i = 1 To UBound(x)

        x(i, 1) = rng(1, 1).Formula
        If Len(x(i, 6)) = 0 Or InStr(x(i, 6), "=") Then x(i, 6) = rng(1, 6).Formula
        x(i, 12) = rng(1, 12).Formula

        If Len(x(i, 13)) = 0 Or InStr(x(i, 13), "=") Then x(i, 13) = rng(1, 13).Formula
        If Len(x(i, 14)) = 0 Or InStr(x(i, 14), "=") Then x(i, 14) = rng(1, 14).Formula
        If Len(x(i, 15)) = 0 Or InStr(x(i, 15), "=") Then x(i, 15) = rng(1, 15).Formula
        If Len(x(i, 16)) = 0 Or InStr(x(i, 16), "=") Then x(i, 16) = rng(1, 16).Formula
        If Len(x(i, 17)) = 0 Or InStr(x(i, 17), "=") Then x(i, 17) = rng(1, 17).Formula
        x(i, 18) = rng(1, 18).Formula

        If Len(x(i, 19)) = 0 Or InStr(x(i, 19), "=") Then x(i, 19) = rng(1, 19).Formula
        If Len(x(i, 20)) = 0 Or InStr(x(i, 20), "=") Then x(i, 20) = rng(1, 20).Formula
        x(i, 21) = rng(1, 21).Formula
        x(i, 22) = rng(1, 22).Formula

        If Len(x(i, 23)) = 0 Or InStr(x(i, 23), "=") Then x(i, 23) = rng(1, 23).Formula
        If Len(x(i, 24)) = 0 Or InStr(x(i, 24), "=") Then x(i, 24) = rng(1, 24).Formula
        If Len(x(i, 25)) = 0 Or InStr(x(i, 25), "=") Then x(i, 25) = rng(1, 25).Formula
        x(i, 26) = rng(1, 26).Formula

        If Len(x(i, 27)) = 0 Or InStr(x(i, 27), "=") Then x(i, 27) = rng(1, 27).Formula
        If Len(x(i, 28)) = 0 Or InStr(x(i, 28), "=") Then x(i, 28) = rng(1, 28).Formula
        If Len(x(i, 29)) = 0 Or InStr(x(i, 29), "=") Then x(i, 29) = rng(1, 29).Formula

        If Len(x(i, 33)) = 0 Or InStr(x(i, 33), "=") Then x(i, 33) = rng(1, 33).Formula
        x(i, 34) = rng(1, 34).Formula
        x(i, 35) = rng(1, 35).Formula

        If Len(x(i, 36)) = 0 Or InStr(x(i, 36), "=") Then x(i, 36) = rng(1, 36).Formula
    Next i

    .Range("A11:AJ11").Resize(UBound(x)).Value = x
End With

With Application
    .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
MsgBox Timer - tm, 64
End Sub

[/vba]

Markovich, привет
попробуйте:

[vba]

Код

[/vba]

nilem

Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem - Пятница, 26.02.2021, 09:19

Ответить

СообщениеMarkovich, привет
попробуйте:

[vba]

Код

[/vba]

Автор - nilem
Дата добавления - 26.02.2021 в 09:18

Markovich

Дата: Пятница, 26.02.2021, 16:40 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 50

Репутация: 0 ±

Замечаний: 0% ±

Excel 2019

nilem, здравствуйте! большое спасибо за код, работает быстро, 150 строк обрабатывает за 0,41с, а 3000 строк за 14с, а ни как у меня в оригинале зависало до бесконечности. Очень здорово! Обязательно изучу код, оптимизирую другие свои нешустрые макросы. hands