Как можно ускорить скорость макроса?

[staniiislav]

Здравствуйте Ув. форумчане.
Подскажите пожалуйста, как можно ускорить вот такой макрос:

Sub po_mecyacy()
If MsgBox("Искать в БД по месяцу и году?", vbYesNo, "Подтверждение") = vbYes Then
ThisWorkbook.Worksheets("Итоги").Outline.ShowLevels ColumnLevels:=1
'[CH5] = ("Всего:")
Dim wsh As Worksheet, wb As Workbook, x, i As Long, k As Long, imonth As String, shname As String
Application.ScreenUpdating = False
imonth = Month([CV1]): shname = Year([CV1])
Set wb = GetObject(ThisWorkbook.Path & "\Архив\БД.xls")
On Error GoTo Handler: With wb.Sheets(shname):
    x = .Range("A1:EK" & .Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = 4 To UBound(x, 1) Step 50
        If Month(x(i, 1)) = (imonth) Then
            .Range("A4:EK53").Offset(i - 4).Copy Range("A6").Offset(50 * k)
            k = k + 1
        End If
    Next i
    If k = 0 Then MsgBox "В " & imonth & " месяце " & shname & "г., еще не закрывались", vbInformation
    wb.Close (False): End With: On Error GoTo 0: If k > 0 Then ActiveSheet.Range("$A$1:$EK$2000").AutoFilter Field:=4, Criteria1:=RGB(0, _
        255, 0), Operator:=xlFilterCellColor

 
    Application.ScreenUpdating = True: Exit Sub
Handler:
MsgBox "Лист " & shname & ", или данные на этом листе, отсутствует в книге БД.xls", vbInformation: wb.Close (False): Exit Sub
Else
   End If
   
End Sub

Заранее спасибо!

[EducatedFool]

А зачем его ускорять?
Он сильно медленно работает? Сколько времени происходит копирование?

Ускорить можно, если необходимо копирование только значений.
(если копировать требуется с форматированием - ускорить не получится)

Формулы на листах есть? Если да - то на время выполнения макроса надо отключать их пересчёт (это ускорит выполнение кода)

Сколько строк в файле БД.xls?

[staniiislav]

Сообщение от EducatedFool

А зачем его ускорять?
Он сильно медленно работает? Сколько времени происходит копирование?

Ускорить можно, если необходимо копирование только значений.
(если копировать требуется с форматированием - ускорить не получится)

Формулы на листах есть? Если да - то на время выполнения макроса надо отключать их пересчёт (это ускорит выполнение кода)

Сколько строк в файле БД.xls?

Мне кажется что медленно...
Формулы есть, после копирования подсчитывается суммы или средние значения по полученному результату.
Столбцов 140
Файл БД, содержит 10 листов (1 лист это один год), заполнятся один лист может до 10 000 строк, время обработки около 2 мин (1:45), это если одно из условий искать в конкретном лист БД, есть еще одно условие, искать по все листам (еще дольше).
Спасибо за быстрый ответ!!! Буду пытаться делать по Вашему совету отключение пересчета и копирование только значений.

[staniiislav]

EducatedFool подскажите пожалуйста какой код по отключению/включению пересчета и куда нужно вставить в мой пример; как сделать копирование только значений в моем примере?
Заранее спасибо!
С Ув. Станислав

[EducatedFool]

Попробуйте так:

Sub po_mecyacy()
    If MsgBox("Искать в БД по месяцу и году?", vbYesNo, "Подтверждение") <> vbYes Then Exit Sub

    ThisWorkbook.Worksheets("Итоги").Outline.ShowLevels ColumnLevels:=1
    '[CH5] = ("Всего:")
    Dim wsh As Worksheet, wb As Workbook, x, i As Long, k As Long, imonth As String, shname As String
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual    ' отключаем пересчёт формул

    imonth = Month([CV1]): shname = Year([CV1])
    Set wb = GetObject(ThisWorkbook.Path & "\Архив\БД.xls")
    On Error Resume Next: Err.Clear
    With wb.Sheets(shname)
        x = .Range("A1:EK" & .Cells(Rows.Count, 3).End(xlUp).Row).Value
        If Err Then
            MsgBox "Лист " & shname & ", или данные на этом листе, отсутствует в книге БД.xls", vbInformation
        Else
            For i = 4 To UBound(x, 1) Step 50
                If Month(x(i, 1)) = (imonth) Then
                    .Range("A4:EK53").Offset(i - 4).Copy Range("A6").Offset(50 * k)
                    k = k + 1
                End If
            Next i
            If k = 0 Then MsgBox "В " & imonth & " месяце " & shname & "г., еще не закрывались", vbInformation
            If k > 0 Then ActiveSheet.Range("$A$1:$EK$2000").AutoFilter Field:=4, Criteria1:=RGB(0, 255, 0), Operator:=xlFilterCellColor
        End If
        wb.Close (False)
    End With

    Application.Calculation = xlCalculationAutomatic    ' включаем обратно пересчёт формул
End Sub

[staniiislav]

Спасибо огромное EducatedFool, правда разница не ощущается к сожалению . Попробовал в новую книгу выгрузить, заняло около 5 сек ))) видимо сам фаил перегрузил... Попытаюсь все заново переделать в новой книге. Думаю поможет. Еще раз спасибо EducatedFool!

[staniiislav]

EducatedFool, последний вопрос. Что нужно подправить в макросе, чтобы он работал в xlsm или xlsx?

[staniiislav]

))) не буду надоедать. Спасибо за ответ! Тему можно закрывать.