Excel vba在大数据工作表中执行缓慢

下面的代码真的很慢，我的电脑需要一些时间才能完成操作。 我试图从author_metadata使用更less的行，但是甚至有40000行太多。 用excel VBA有更快的select吗？

 author_metadata = ThisWorkbook.Worksheets("author_metadata").Range("A1:P542995").Value allprofs = ThisWorkbook.Worksheets("allprofs").Range("A1:H4005").Value Top200 = ThisWorkbook.Worksheets("Top200").Range("A1:B200").Value m = 1 For j = 1 To 200 For k = 1 To 4005 If allprofs(k, 4) = Top200(j, 1) Then For i = 2 To UBound(author_metadata) If author_metadata(i, 10) = Top200(j, 1) Then If allprofs(k, 2) = author_metadata(i, 12) Then 'do some data assigning between arrays like the next line Top200Full(m, 1) = author_metadata(i, 1) m = m + 1 End If End If Next i End If Next k Next j ThisWorkbook.Worksheets("Top200full").Range("A2:Q75601").Value = Top200Full End Sub 

Answer 1

使用AutoFilter()方法和Dictionary对象

如果我正确地掌握了你的逻辑，一个可能的代码可能如下

 Option Explicit Sub main() Dim Top200 As Variant, allproofFiltered As Variant Dim m As Long Dim cell As Range Dim allproofFilteredDict As Scripting.Dictionary Top200 = Application.Transpose(ThisWorkbook.Worksheets("Top200").Range("A1:A200").Value) With ThisWorkbook.Worksheets("allprofs") With .Range("D1", .Cells(.Rows.count, "D").End(xlUp)) .AutoFilter Field:=1, Criteria1:=Top200, Operator:=xlFilterValues '<--| filter referenced range on its 3rd column (ie "State") with 1 If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filterd cells other than header Set allproofFilteredDict = New Scripting.Dictionary For Each cell In .Resize(.Rows.count - 1).Offset(1, -2).SpecialCells(xlCellTypeVisible) allproofFilteredDict(cell.Value) = cell.Value Next allproofFiltered = allproofFilteredDict.keys Else Exit Sub End If End With .AutoFilterMode = False End With With ThisWorkbook.Worksheets("author_metadata") With .Range("J1:L" & .UsedRange.Rows(.UsedRange.Rows.count).Row) .AutoFilter Field:=1, Criteria1:=Top200, Operator:=xlFilterValues '<--| filter referenced range on its 3rd column (ie "State") with 1 .AutoFilter Field:=3, Criteria1:=allproofFiltered, Operator:=xlFilterValues '<--| filter referenced range on its 3rd column (ie "State") with 1 If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any filterd cells other than header .Resize(.Rows.count - 1, 1).Offset(1, -9).SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Worksheets("Top200full").Range("A2").PasteSpecial xlPasteValues End If End With .AutoFilterMode = False End With End Sub 

要使用Dictionary对象，您必须将其库引用添加到您的项目中：

• 单击工具 – >参考

• 向下滚动列表框到“Microsoft Scripting Dictionary”条目并勾选它的复选标记

• 单击确定

Answer 2

这有时有助于加快我的代码;

 Application.Calculation = xlCalculationManual Application.EnableEvents = False