Question

Sub test()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

Dim x As Workbook
Dim y As Workbook

Set x = ActiveWorkbook
Set y = Workbooks.Open("S:\HR\Attendance Charts\2014\May 14\abc.xlsx")

y.Sheets("Report").Activate
ActiveSheet.Range("A34:DM64").Copy

x.Sheets("Modified").Activate
ActiveSheet.Range("A70").PasteSpecial xlPasteValues

y.Close
End Sub

我正在使用此代码将一些数据从x工作簿复制到y工作簿。 x工作簿的大小为13 MB，Y为23.5 MB。从x复制数据并将其粘贴到y需要花费大量时间。无论如何，我可以让这个过程运行得更快吗？我正在使用上面的代码。谢谢

Answer 1

根据http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm，以下内容可能会使您的代码更快（绕过剪贴板并直接复制值）：

Sub test()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

Dim x As Workbook
Dim y As Workbook
Dim r1 As Range ' source
Dim r2 As Range ' destination

Set x = ActiveWorkbook
Set y = Workbooks.Open("S:\HR\Attendance Charts\2014\May 14\abc.xlsx")

Set r1 = y.Sheets("Report").Range("A34:DM64")
Set r2 = x.Sheets("Modified").Range("A70:DM100") 
r2.Value = r1.Value '<<<<<<<<< this is the line that does the magic

y.Close

End Sub

检查我是否正确设置了范围r1和r2 ...

Answer 2

我改变了Floris的代码，尝试使用VBA数组

Sub test()

with Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .AskToUpdateLinks = False
    .enableevents=false
    .calculation = Xlmanual
end with

Dim x As Workbook
Dim y As Workbook
Dim r1 As Range ' source
Dim r2 As Range ' destination
Dim Y_Array() as Variant
dim Y_Sheet as Worksheet
Dim X_Sheet as Worksheet

Set x = ActiveWorkbook
Set X_Sheet= x.Sheets("Modified") '=activesheet ' i've preferably named it with complete name here

'testing if y already opened, if it's the case win a lot of time
err.clear
on error resume next
Set y = Workbooks ("abc.xlsx")
if err<>0 then
    err.clear
    Set y = Workbooks.Open("S:\HR\Attendance Charts\2014\May 14\abc.xlsx")
end if
on error goto 0

with y
    application.windows(.name).windowstate=xlminimized
    set Y_Sheet= .Sheets("Report")
    with Y_Sheet
        Set r1 = .Range(.cells(34,1) , .cells(64,117) ) ' same as "A34:DM64")
        with r1
            redim Y_Array (1 to 30, 1 to 117) 'to make it a dynamic array : (1 to .rows.count, 1 to .columns.count)
            Y_Array = .value2 'edit : modified to .value2
        end with
    end with
end with

Set r2 = x.Sheets("Modified").Range("A70:DM100") 

r2.Value2 = Y_Array 'r1.Value '<<<<<<<<< this is the line that does the magic 'edit: modified to value2

y.Close

'Free memory
erase Y_Array
set r1=nothing
set Y_Sheet=nothing
set Y=nothing
set r2=nothing
set X_Sheet=nothing
set X=nothing

with Application
    .ScreenUpdating = true 'uh, without reseting it to normal you gonna have troubles....
    .DisplayAlerts = true
    '.AskToUpdateLinks = true
    .enableevents = true
    .calculation = XlAutomatic
end with

End Sub

代码未经测试，不确定它真的有帮助，试一试......

使复制粘贴过程运行得更快

2 个答案: