如何缩短VBA在筛选工作表中跨工作簿范围搜索的运行时间

需要遍历工作簿A的1000-3000行，在工作簿B中查找匹配的唯一行（匹配条件为国家+SKU），若找到则将B中对应信息写入A，但当前代码运行耗时数小时。工作簿B原含8-10万行，已提前筛选至800-3000行，尝试过复制筛选数据到新工作簿、取消xlCellTypeVisible、将循环对象从subrng.areas改为rng，但耗时问题仍未解决。

原始VBA代码如下：

Sub Wb_to_APT()

    Dim openedWb As Workbook, APTex As Workbook
    Dim MainView As Worksheet, dis As Worksheet
    Dim disFilter As Range, filterow As Range, rng As Range, subrng As Range
    Dim countryCol1, countryCol2, SKUcol1, SKUcol2, fCol, disFCol, r As Long
    Dim i As Integer


' Must use the APT MainView export to run the macro
    Set MainView = ActiveWorkbook.ActiveSheet


' Tells the user to open the dis file they want to copy from
    Set openedWb = openDataFile
    Set dis = openedWb.Worksheets("DIS")

' Find the last row of the APT export and dis, and fix dynamic column indices
    With dis
        countryCol1 = Application.Match("Territory", MainView.Rows(1), 0)
        countryCol2 = Application.Match("TERRITORY", .Rows(1), 0) + 1
        SKUcol1 = Application.Match("StyleColor", MainView.Rows(1), 0)
        SKUcol2 = Application.Match("PROD_CD", .Rows(1), 0)
        fCol = Application.Match("UFlow1", MainView.Rows(1), 0)
        disFCol = Application.Match("UF1", .Rows(1), 0)
        r = MainView.Cells(Rows.Count, SKUcol1).End(xlUp).Row
        'r_end = .Cells(Rows.Count, SKUcol2).End(xlUp).Row
        Set rng = .Range(.Cells(2, SKUcol2), .Cells(.Cells(Rows.Count, SKUcol2).End(xlUp).Row, SKUcol2))
        Set subrng = rng.SpecialCells(xlCellTypeVisible)
    End With
    
' Iterate through Main View export to find same country-SKU in dis
    With dis
        For i = 2 To r
        ' only check filtered rows in dis
            For Each disFilter In subrng.areas
        ' match countries and SKUs
                If .Cells(disFilter.Row, countryCol2).Value2 = MainView.Cells(i, countryCol1).Value2 And _
                .Cells(disFilter.Row, SKUcol2).Value2 = MainView.Cells(i, SKUcol1).Value2 Then
                    MainView.Cells(i, fCol) = .Cells(disFilter.Row, disFCol).Value2
                    MainView.Cells(i, fCol + 1) = .Cells(disFilter.Row, disFCol + 1).Value2
                    MainView.Cells(i, fCol + 2) = .Cells(disFilter.Row, disFCol + 2).Value2
                    Exit For
                Else
                    MainView.Cells(i, fCol) = "NOT FOUND OR FILTERED OUT"
                End If
            Next disFilter
        Next
    End With

End Sub

优化思路 #

核心是消除嵌套循环遍历单元格，改用字典实现O(1)时间复杂度的快速匹配，同时关闭Excel的后台操作减少资源消耗：

• 关闭屏幕刷新、事件触发和自动计算，避免运行中不必要的资源占用
• 将工作簿B的筛选后数据批量加载到字典，用国家+SKU拼接成唯一键，对应值存储需要写入的3列数据数组
• 遍历工作簿A时直接通过字典键查找匹配项，一次完成数据写入，彻底解决嵌套循环的性能瓶颈

优化后代码 #

Sub Wb_to_APT_Optimized()
    Dim openedWb As Workbook, MainView As Worksheet, dis As Worksheet
    Dim countryCol1, countryCol2, SKUcol1, SKUcol2, fCol, disFCol, r As Long
    Dim i As Long, lastRowDis As Long
    Dim matchDict As Object
    Dim keyStr As String
    Dim visibleRows As Range, cell As Range
    
    ' 关闭Excel后台操作，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set MainView = ActiveWorkbook.ActiveSheet
    Set openedWb = openDataFile
    Set dis = openedWb.Worksheets("DIS")
    Set matchDict = CreateObject("Scripting.Dictionary")
    
    ' 获取列索引
    With dis
        countryCol1 = Application.Match("Territory", MainView.Rows(1), 0)
        countryCol2 = Application.Match("TERRITORY", .Rows(1), 0) + 1
        SKUcol1 = Application.Match("StyleColor", MainView.Rows(1), 0)
        SKUcol2 = Application.Match("PROD_CD", .Rows(1), 0)
        fCol = Application.Match("UFlow1", MainView.Rows(1), 0)
        disFCol = Application.Match("UF1", .Rows(1), 0)
        r = MainView.Cells(Rows.Count, SKUcol1).End(xlUp).Row
        lastRowDis = .Cells(Rows.Count, SKUcol2).End(xlUp).Row
    End With
    
    ' 将工作簿B的筛选后数据加载到字典
    On Error Resume Next ' 忽略隐藏行的错误
    Set visibleRows = dis.Range(dis.Cells(2, SKUcol2), dis.Cells(lastRowDis, SKUcol2)).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not visibleRows Is Nothing Then
        For Each cell In visibleRows
            keyStr = dis.Cells(cell.Row, countryCol2).Value2 & "|" & cell.Value2 ' 拼接唯一键
            ' 存储需要写入的3列数据
            matchDict(keyStr) = Array(dis.Cells(cell.Row, disFCol).Value2, _
                                     dis.Cells(cell.Row, disFCol + 1).Value2, _
                                     dis.Cells(cell.Row, disFCol + 2).Value2)
        Next cell
    End If
    
    ' 遍历工作簿A，匹配并写入数据
    With MainView
        For i = 2 To r
            keyStr = .Cells(i, countryCol1).Value2 & "|" & .Cells(i, SKUcol1).Value2
            If matchDict.Exists(keyStr) Then
                ' 批量写入3列数据
                .Cells(i, fCol).Resize(1, 3).Value = matchDict(keyStr)
            Else
                .Cells(i, fCol).Value = "NOT FOUND OR FILTERED OUT"
                ' 清空后续两列（如果需要）
                .Cells(i, fCol + 1).Resize(1, 2).ClearContents
            End If
        Next i
    End With
    
    ' 恢复Excel后台设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    Set matchDict = Nothing
    MsgBox "数据匹配完成！", vbInformation
End Sub

内容的提问来源于stack exchange，提问作者user75667