1

Есть файл книга2, в него попадают данные с книга3 по прописанному макросу

К сожалению, возможно, из-за больших объемов и надстроек макросов в файле, работа макроса может занять 10-20 минут. Различные решения оптимизации пробовал добавить, но пока безуспешно.

Количество и объем данных примерно занимает где-то 6 колонок на 200 и более строк, но почему-то процесс идет слишком долго. Полагаю, одна из возможных проблем - это то, что я пытаюсь добавить этот макрос в процесс при изменении в диапозоне A:A в книга2.

Function ifopen(w As String) As Boolean
    On Error Resume Next
    ifopen = Workbooks(w).Name <> ""
End Function

Public Sub hyfre1()
    Application.ErrorCheckingOptions.BackgroundChecking = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.StatusBar = False

If ifopen("книга3") = False Then
Workbooks.Open "C:\Users\nshuvalov\Desktop\книга3.xlsm", ReadOnly:=True
End If

   Dim LastRow As Long
   Dim LastRow2 As Long

    LastRow = Workbooks("книга2").Sheets("план").Cells(Rows.Count, 1).End(xlUp).Row
    LastRow2 = Workbooks("книга3").Sheets("выручка").Cells(Rows.Count, 1).End(xlUp).Row

          With Workbooks("книга2").Sheets("план")


            For s = 2 To LastRow
                For xx = 2 To LastRow2
                If Workbooks("книга2").Sheets("план").Cells(s, 1) = Workbooks("книга3").Sheets("выручка").Cells(xx, 1) Then

                   Workbooks("книга3").Sheets("выручка").Cells(xx, 6).Copy
                   Workbooks("книга2").Sheets("план").Cells(s, 2).PasteSpecial xlPasteValues
                   Workbooks("книга3").Sheets("выручка").Cells(xx, 3).Copy
                   Workbooks("книга2").Sheets("план").Cells(s, 3).PasteSpecial xlPasteValues
                   Workbooks("книга3").Sheets("выручка").Cells(xx, 2).Copy
                   Workbooks("книга2").Sheets("план").Cells(s, 4).PasteSpecial xlPasteValues
                   Workbooks("книга3").Sheets("выручка").Cells(xx, 5).Copy
                   Workbooks("книга2").Sheets("план").Cells(s, 5).PasteSpecial xlPasteValues
               End If
                Next
           Next
        End With

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.StatusBar = True

Application.ErrorCheckingOptions.BackgroundChecking = True
End Sub

1 2

6
  • 2
    Работать с ячейками - гарантированные тормоза. Загрузите сразу все данные в двумерный массив, и там обрабатывайте, гоня результат в другой массив, а затем сразу весь его выплёвывайте на лист.
    – Akina
    11 мар 2020 в 13:55
  • Буфер обмена не используй. Взял значение, записал значение.
    – Qwertiy
    11 мар 2020 в 13:56
  • попробуйте рабоать с данными в книгах как с массивами, учитывая что у вас обычное копирование, проблем не должно быть.
    – Argo7
    11 мар 2020 в 13:56
  • @Akina, что-то сомнительно, что можно получить все значения в массиве не перебирая ячейки.
    – Qwertiy
    11 мар 2020 в 13:57
  • Спасибо за идеи, был бы признателен если бы был бы пример похожий как с таким работать. 11 мар 2020 в 13:58

2 ответа 2

2

На массивах гораздо быстрее. К объектам листа обращаемся только для получения данных и выгрузки результата.

Sub OpenBook_()
    If ifopen("книга3") = False Then
        With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
        Workbooks.Open "C:\Users\nshuvalov\Desktop\книга3.xlsm", ReadOnly:=True
        With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
    End If
End Sub

Function ifopen(w As String) As Boolean
    On Error Resume Next
    ifopen = Workbooks(w).Name <> ""
End Function

' --------------------------------------- '

Public Sub hyfre1()
    Dim aProfit(), aPlan()
    Dim LastRow As Long
    Dim i As Long, n As Long

    Call OpenBook_

    With Workbooks("книга3").Sheets("выручка")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).row
        If LastRow < 2 Then Exit Sub
        aProfit = .Range("A1:F" & LastRow).Value
    End With

    With Workbooks("книга2").Sheets("план")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).row
        If LastRow < 2 Then Exit Sub
        aPlan = .Range("A1:E" & LastRow).Value

        For i = 2 To UBound(aPlan)
            For n = 2 To UBound(aProfit)
                If aPlan(i, 1) = aProfit(n, 1) Then
                    aPlan(i, 2) = aProfit(n, 6)
                    aPlan(i, 3) = aProfit(n, 3)
                    aPlan(i, 4) = aProfit(n, 2)
                    aPlan(i, 5) = aProfit(n, 5)
                    Exit For
                End If
            Next n
        Next i

        Application.ScreenUpdating = False
        .Range("A1:E5" & LastRow).Value = aPlan
        Application.ScreenUpdating = True
    End With
End Sub

Если номера заказов в двух книгах по возрастанию, то можно еще ускорить - вложенный цикл просматривать не со второй, а с последней найденной строки. Объявить еще одну переменную и изменить фрагмент кода:

k = 2

For i = 2 To UBound(aPlan)
    For n = k To UBound(aProfit)
        If aPlan(i, 1) = aProfit(n, 1) Then
            k = n + 1
            aPlan(i, 2) = aProfit(n, 6)
3
  • aPlan = .Range("A1:E" & LastRow).Value точно не Value2 должно быть? 11 мар 2020 в 15:30
  • Нет, одна переменная использована дважды (небольшая, но экономия памяти) 11 мар 2020 в 15:33
  • О, вопрос не о 'LastRow/LastRow2'... Да, обычно берем '.Value' 11 мар 2020 в 15:42
1
Dim Src As Sheet, Dest as Sheet
Set Src = Workbooks("книга3").Sheets("выручка")
Set Dest = Workbooks("книга2").Sheets("план")
Workbooks("книга3").Sheets("выручка").Cells(xx, 6).Copy
Workbooks("книга2").Sheets("план").Cells(s, 2).PasteSpecial xlPasteValues
Dest.Cells(s, 2).Value = Src.Cells(xx, 6).Value
1
  • Спасибо огромное, правда намного шустрее работает 11 мар 2020 в 14:19

Ваш ответ

Нажимая на кнопку «Отправить ответ», вы соглашаетесь с нашими условиями использования и подтверждаете, что прочитали и поняли наши политику конфиденциальности и нормы поведения.

Всё ещё ищете ответ? Посмотрите другие вопросы с метками или задайте свой вопрос.