与其他文件相比，在一个文件中将数据从工作簿复制到当前工作簿的速度非常慢
与其他文件相比，在一个文件中将数据从工作簿复制到当前工作簿的速度非常慢
提问于 2019-06-25 02:10:25
我有一个代码，可以从我们选择的任意数量的工作簿中加载数据，并加载到当前工作簿中。它在隔离的情况下工作得很好(在一个我不执行任何其他任务的文件中)。但是，当我在一个大文件中使用这段代码时，我在许多数组函数中使用(引用)复制的数据，加载1-2个文件需要20分钟，而以前需要几秒钟。
有没有可能它的速度很慢，因为链接到其他带有功能的标签页？我是不是错过了什么。任何帮助都将不胜感激。
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.Calculation = xlCalculationManual
Number = 0
IT = 0
Set thisWb = ActiveWorkbook
Set ws = thisWb.Sheets("CF")
thisWb.Sheets("CF").Select
ws.Range(ws.Cells(2, 1), ws.Cells(100000, 42)).ClearContents
Do
files = Application.GetOpenFilename(filefilter:="Excel workbooks (*.csv*),*.csv*", Title:="Select files to import", MultiSelect:=True)
If Not IsArray(files) Then Exit Sub 'Cancel must have been clicked
If UBound(files) < 1 Then
MsgBox "You have not selected any file. Please select files."
End If
Loop Until UBound(files) > 0
Number = UBound(files)
N = Number + N
For IT = 1 To UBound(files)
Workbooks.Open files(IT)
With ActiveWorkbook
Application.CutCopyMode = False
Set wk = ActiveWorkbook.ActiveSheet
.ActiveSheet.Range("A2:AP10000").Copy
'LastRow = wk.Cells(Rows.Count, "A").End(xlUp).Row
thisWb.Activate
ws.Select
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRow).Select
Set Rng = ws.Range("A" & LastRow)
Rng.PasteSpecial xlPasteValues
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Application.CutCopyMode = False
.Close False
End With
Next任何可以让这段代码运行得更快的东西，比如立即加载3-4个小文件，都将是完美的。
回答 1
Stack Overflow用户
回答已采纳
发布于 2019-06-25 03:01:25
下面是一个如何创建变量和对象以跟踪您正在使用的工作簿和工作表以及数据源的示例。还要注意的是，为了提高速度，我将数据从Range复制到基于内存的数组中。
还要注意的是，强烈建议始终使用Option Explicit。
Option Explicit
Sub test()
Dim number As Long
Dim it As Long
number = 0
it = 0
Dim thisWB As Workbook
Dim ws As Worksheet
Set thisWB = ActiveWorkbook
Set ws = thisWB.Sheets("CF")
'--- clear the worksheet
ws.Cells.Clear
Dim files As Variant
Do
files = Application.GetOpenFilename(filefilter:="Excel workbooks (*.csv*),*.csv*", _
Title:="Select files to import", _
MultiSelect:=True)
If Not IsArray(files) Then Exit Sub 'Cancel must have been clicked
If UBound(files) < 1 Then
MsgBox "You have not selected any file. Please select files."
End If
Loop Until UBound(files) > 0
Dim n As Long
number = UBound(files)
Dim csvWB As Workbook
Dim csvWS As Worksheet
Dim csvData As Variant
Dim dataRange As Range
Dim lastRow As Long
Dim rng As Range
For it = 1 To UBound(files)
Set csvWB = Workbooks.Open(files(it))
With csvWB
Set csvWS = csvWB.Sheets(1)
csvData = csvWS.UsedRange 'copy to memory-based array
'Set csvData = csvWS.Range("A2:AP10000") 'copy to memory-based array
Set dataRange = ws.Range("A1").Resize(UBound(csvData, 1), UBound(csvData, 2))
dataRange.Value = csvData
.Close False
End With
Next
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/56741867
复制相关文章
相似问题