Question

下面的代码非常慢我的电脑需要一些时间来完成操作。我尝试使用来自author_metadata的更少行，但即使40000行太多。 excel VBA有更快的替代方案吗？

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 (i.e. "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 (i.e. "State") with 1
            .AutoFilter Field:=3, Criteria1:=allproofFiltered, Operator:=xlFilterValues '<--| filter referenced range on its 3rd column (i.e. "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对象，必须将其库引用添加到项目中：

点击工具 - ＆gt;参考
向下滚动列表框到＆＃34; Microsoft Scripting Dictionary＆＃34;输入并勾选其复选标记
点击确定

Answer 2

这有时会加快我的代码速度;

Application.Calculation = xlCalculationManual 
Application.EnableEvents = False

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

2 个答案: