如何解决Excel阵列和小型VBA循环与不带阵列的大型VBA循环的性能
我有两个工作表。第一个（计算）包含10.000行，其中包含许多RTD公式和不同的计算。第二个（观察者）工作表观察第一个。 现在，我运行了一个vba脚本，该脚本每秒运行一次，并检查工作表1（计算）的每个单行。如果循环在工作表1上找到一些标记的数据，那么它将把一些数据从WS1复制到WS2。 解决方案1：VBA循环检查10.000行
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For I = 1 To 10000
If CStr(.Cells(I,1)) = "X" Then
'DO SOME SUFF (copy the line from WS 1 to WS2)
'Find first empty row
LR2 = WS2.Cells(15,1).End(xlDown).Row + 1
'copy data from WS1 to WS2
WS1.Range(.Cells(I,1),.Cells(I,14)).copy
WS2.Cells(LR2,1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
解决方案2：带有小循环的数组函数 我很想知道我是否可以使用而不是10.000行循环的Excel数组来观察10.000行，并使用较小的数组做一些事情。 在工作表2上，我将具有以下代码：（A1：O15）
{=index(Calculation!A$1:$O$10000; .....)....))}
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For K = 1 To 15
If CStr(.Cells(I,1)) = "X" Then
'Find first empty row
LR2 = WS2.Cells(15,1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
我想知道哪种解决方案具有更好的性能。我不确定超过10.000行的Excel数组是否具有良好的性能。确保15行循环比10000行循环快。
但是我不确定与数组连接的15行循环（观察10.000行）是否更快。而且我不知道如何测量。
您有遇到这种情况的经验吗？
问候
解决方法
而不是返回到列 A 10,000次，而是将所有值放入一维VBA数组中，然后在该数组上循环：
Sub whatever()
Dim rng As Range,arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = WorksheetFunction.Transpose(rng)
For i = 1 To 10000
If arr(i) = "X" Then
'do some stuff
End If
Next i
End Sub
如果 X 很少，则可能几乎是瞬时的。
EDIT＃1：
根据Chris Neilsen的评论，这是一个不使用Transpose()的版本：
Sub whatever2()
Dim rng As Range,arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = rng
For i = 1 To 10000
If arr(i,1) = "X" Then
'do some stuff
End If
Next i
End Sub
使用条件复制到工作表
- 将工作表中包含指定列中指定值（
Criteria）的数据集的每一行复制到另一个工作表。 - 调整
createReport的常量部分中的值。 - 仅（例如）在激活工作表“
Observer”时才会发生数据传输。当前选择另一个工作表并单击“Observer”选项卡时。 li> - 此代码在一百万（全部）行上花费了大约5秒钟，而在我的计算机上花费了10秒不到一秒钟。
- 通过将代码与“
Worksheet Change”工作表中的Calculation事件一起使用并关闭某些Application事件（例如.ScreenUpdating，可以进一步提高效率。.Calculation，.EnableEvents）。
Excel测试设置（工作表“计算”）
[A1:I1] ="Column "&COLUMN()
[A2] =IF(I2=1,"X","Y")
[B2:H2] =RANDBETWEEN(1,1000)
[I2] =RANDBETWEEN(1,100)
工作表模块（工作表“观察员”）
Option Explicit
Private Sub Worksheet_Activate()
createReport
End Sub
标准模块，例如Module1
Option Explicit
Sub createReport()
' Constants
' Source
Const srcName As String = "Calculation"
Const CriteriaColumn As Long = 1
Const Criteria As String = "X"
Const srcFirstCellAddress As String = "A1"
' Target
Const tgtName As String = "Observer"
Const tgtFirstCellAddress As String = "A1"
Const includeHeaders As Boolean = True
' Other
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Range ('rng').
' Define Source First Cell ('cel').
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirstCellAddress)
' Define the Current Region ('rng') 'around' First Cell.
Dim rng As Range
Set rng = cel.CurrentRegion
' Define Source Range ('rng') i.e. exclude cells to the left and above
' of Source First Cell from the Current Region.
Set rng = rng.Resize(rng.Rows.Count - cel.Row + rng.Row,_
rng.Columns.Count - cel.Column + rng.Column) _
.Offset(cel.Row - rng.Row,cel.Column - rng.Column)
' Write values from Source Range to Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write resulting values from Data Array to Data Array
' i.e. 'shift' them to the beginning.
Dim NoC As Long ' Number of Columns
NoC = UBound(Data,2)
Dim i As Long ' Source Data Rows Counter
Dim j As Long ' Source/Target Data Columns Counter
Dim CurrentRow As Long ' Target Data Rows Counter
Dim checkHeaders As Long
checkHeaders = -CLng(includeHeaders) ' True is '-1' in VBA.
CurrentRow = checkHeaders
For i = 1 To UBound(Data,1)
If Data(i,CriteriaColumn) = Criteria Then
CurrentRow = CurrentRow + 1
For j = 1 To NoC
' 'Shift' from 'i' to 'CurrentRow'.
Data(CurrentRow,j) = Data(i,j)
Next j
End If
Next i
' Write values from Data Array to Target Range ('rng').
' Define Target First Cell ('cel').
Set cel = wb.Worksheets(tgtName).Range(tgtFirstCellAddress)
' Define Target First Row ('rng').
Set rng = cel.Resize(,NoC)
' Clear contents in columns.
rng.Resize(rng.Worksheet.Rows.Count - cel.Row + 1).ClearContents
Select Case CurrentRow
Case 0
GoTo CriteriaNotFound
Case checkHeaders
' Write headers from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo CriteriaNotFound
Case Else
' Write values from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo Success
End Select
' Exit.
ProcExit:
Exit Sub
' Inform user.
CriteriaNotFound:
MsgBox "Value '" & Criteria & "' not found.",vbExclamation,"Fail"
GoTo ProcExit
Success:
MsgBox CurrentRow - checkHeaders & " row(s) of data transferred.",_
vbInformation,"Success"
GoTo ProcExit
End Sub
请测试下一个代码。使用数组和发生在内存中的一切，它应该非常快。该代码假定您需要复制从WS2的最后一个空单元格开始的所有匹配项：
Sub CopyFromWS1ToWs2Array()
Dim WS1 As Worksheet,WS2 As Worksheet,lastRow As Long,searchStr As String
Dim LR2 As Long,arr1 As Variant,arr2 As Variant,i As Long,k As Long,j As Long
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range in an array
ReDim arr2(1 To UBound(arr1,2),1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i,1) = searchStr Then
k = k + 1 'the array row is incremented (in fact,it is the column now...)
For j = 1 To UBound(arr1,2)
arr2(j,k) = arr1(i,j) 'the row is loaded with all the necessary values
Next j
End If
Next i
'the final array is Redim,preserving only the existing values:
ReDim Preserve arr2(1 To UBound(arr1,1 To k)
LR2 = WS2.cells(rows.count,1).End(xlUp).row + 1 'last empty row of the second worksheet
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2).Resize(UBound(arr2,UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2).Select
MsgBox "Ready...",vbInformation,"Job done"
End Sub
已编辑：
请测试下一个代码，该代码也应解决您的最后一个请求（据我的理解）：
Sub CopyFromWS1ToWs2ArrayBis()
Dim WS1 As Worksheet,arrWS2 As Variant
Dim i As Long,j As Long,s As Long,boolFound As Boolean
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
LR2 = WS2.cells(rows.count,1).End(xlUp).row 'last empty row of the second worksheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range of WS1 in an array
ReDim arr2(1 To UBound(arr1,1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
arrWS2 = WS2.Range("A1:N" & LR2).Value 'put the range of WS2 in an array
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i,1) = searchStr Then
For s = 1 To UBound(arrWS2)
If arr1(i,1) = arrWS2(s,1) And arr1(i,2) = arrWS2(s,2) And _
arr1(i,3) = arrWS2(s,3) Then
boolFound = True: Exit For 'if first three array columns are the same
End If
Next s
If Not boolFound Then 'if first thrree array columns not the same:
k = k + 1 'the array row is incremented
For j = 1 To UBound(arr1,2)
arr2(j,j) 'the row is loaded with all the necessary values
Next j
'swap the columns 4 and 5 values:
If arr1(i,4) = "ABC" And arr1(i,5) = "XYZ" Then arr2(4,k) = "XYZ": arr2(5,k) = "ABC"
End If
boolFound = False 'reinitialize the boolean variable
End If
Next i
If k > 0 Then
'Preserving only the existing array elements:
ReDim Preserve arr2(1 To UBound(arr1,1 To k)
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2 + 1).Resize(UBound(arr2,UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2 + 1).Select
MsgBox "Ready...","Job done"
Else
MsgBox "No any row to be copied!","Nothing changed"
End If
End Sub
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。
