Копирование данных между книгами. Ускорение времени работы кода вба

Question

Есть файл книга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

Answer 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

Answer 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)

БЛОГ НА HUSL

Копирование данных между книгами. Ускорение времени работы кода вба

Ответы (2 шт):