主页 / 问题 / 1093440
Accepted
Nikita Shuvalov
Asked:2020-03-11 21:38:27 +0000 UTC2020-03-11 21:38:27 +0000 UTC

在工作簿之间复制数据。WBA代码加速

  • 772

有一个文件，来自规定宏的数据книга2进入其中книга3

不幸的是，可能由于文件中的大量和宏加载项，宏可能需要 10-20 分钟才能完成。尝试添加各种优化方案，但至今没有成功。

200 行或更多行的数据量和数量大约需要 6 列，但由于某种原因，该过程需要太长时间。我想可能的问题之一是我试图将此宏添加到进程中，以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

一 2

excel

2 个回答

  1. 在阵列上要快得多。我们仅引用工作表对象来接收数据并卸载结果。

    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)
    • 2
  2. Best Answer
    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

相关问题