优化跨不同工作簿多工作表的数据提取速度

当前使用如下VBA代码从两个各含200万行、5列数据的工作表中提取特定数据，处理速度极慢，核心瓶颈为搜索操作，寻求速度与效率优化建议。

Sub HFMEMBER_ID()
    Application.ScreenUpdating = FALSE
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = FALSE
    Application.DisplayAlerts = FALSE
    
    Dim wb1         As Workbook        ' Workbook1
    Dim wb2         As Workbook        ' Workbook2
    Dim wsHF        As Worksheet
    Dim wsWellcare  As Worksheet
    Dim searchValue As Variant
    Dim lastRow     As Long
    Dim sourceRowData As Variant
    Dim targetRow   As Long
    
    ' Set the source workbook (Workbook1)
    Set wb1 = Workbooks("Merged Data.xlsx")        ' Change the filename if needed
    
    ' Set the target workbook (Workbook2 - where the macro is)
    Set wb2 = ThisWorkbook
    
    ' Set the source and target worksheets
    Set wsHF = wb2.Worksheets("HF")        ' Change "HF" to the name of your source worksheet
    Set wsWellcare = wb2.Worksheets("MEMBER_ID")        ' Change "Wellcare" to the name of your target worksheet
    
    Dim lastRow2    As Long
    lastRow2 = wsWellcare.Cells(wsWellcare.Rows.Count, "A").End(xlUp).Row
    If lastRow2 > 1 Then
        wsWellcare.Range("A2:A" & lastRow2).EntireRow.Delete
    End If
    
    ' Get the last used row in column C of wsHF
    lastRow = wsHF.Cells(wsHF.Rows.Count, "C").End(xlUp).Row
    
    Dim wsSource1   As Worksheet
    Dim wsSource2   As Worksheet
    ' Set the source worksheets
    Set wsSource1 = wb1.Worksheets("HF1")
    Set wsSource2 = wb1.Worksheets("HF2")
    
    ' Loop through each row in column C of wsHF
    For targetRow = 2 To lastRow
        searchValue = wsHF.Cells(targetRow, "C").Value
        
        ' Skip empty cells
        If searchValue = "" Then
            Exit Sub
        End If
        
        ' Search within the first source worksheet (HF1)
        SearchAndCopy3 wsSource1, searchValue, wsWellcare
        
        ' Search within the second source worksheet (HF2)
        SearchAndCopy3 wsSource2, searchValue, wsWellcare
    Next targetRow
    
    ' ... (rest of the code remains the same)
    
    Application.ScreenUpdating = TRUE
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = TRUE
    Application.DisplayAlerts = TRUE
End Sub

Sub SearchAndCopy3(sourceSheet As Worksheet, searchValue As Variant, targetSheet As Worksheet)
    Dim foundCell   As Range
    Dim firstAddress As String
    Dim lastRow     As Long
    Dim sourceRowData As Variant
    Dim targetRow   As Long
    
    ' Find the first instance of the search value in Column C of the current source worksheet
    Set foundCell = sourceSheet.Columns("C:C").Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
    
    ' Check if the value was found at least once
    Do While Not foundCell Is Nothing
        ' If the search value is found, copy the entire row data to the target worksheet (Wellcare)
        sourceRowData = foundCell.EntireRow.Value
        targetRow = targetSheet.Cells(targetSheet.Rows.Count, "C").End(xlUp).Row + 1
        
        ' Copy the entire row data to the target worksheet (Wellcare)
        targetSheet.Cells(targetRow, 1).Resize(1, UBound(sourceRowData, 2)).Value = sourceRowData
        
        ' Find the next instance of the search value in Column C of the current source worksheet
        Set foundCell = sourceSheet.Columns("C:C").FindNext(foundCell)
    Loop
End Sub

核心优化方向 #

1. 用字典预构建搜索索引，替代多次Find操作 #

Find和FindNext在大数据量下反复调用会产生极高的性能开销，改用Dictionary（需引用Microsoft Scripting Runtime，或用CreateObject）将源数据的搜索列（C列）作为键，对应行数据作为值存储，后续直接通过键查找，时间复杂度从O(n)降为O(1)。

2. 批量加载/写入数据，减少单元格交互 #

单元格是Excel中最慢的操作对象之一，将整表数据一次性加载到数组，处理完成后再一次性写入目标工作表，避免逐行读写。

3. 仅处理需要的列，避免整行复制 #

原代码复制整行数据，而实际仅需5列，减少数据传输量能显著提升速度。

4. 优化循环逻辑 #

原代码遇到空值直接Exit Sub，改为跳过空值继续循环；同时合并两个源工作表的索引构建，减少重复操作。

优化后的代码示例 #

Sub Optimized_HFMEMBER_ID()
    ' 关闭Excel非必要功能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Cursor = xlWait
    
    Dim wb1 As Workbook, wb2 As Workbook
    Dim wsHF As Worksheet, wsWellcare As Worksheet
    Dim wsSource1 As Worksheet, wsSource2 As Worksheet
    Dim dict As Object ' 用Dictionary存储索引
    Dim sourceData As Variant, searchList As Variant
    Dim targetData As Variant
    Dim i As Long, j As Long, k As Long, targetRow As Long
    Dim key As Variant, matchedRows As Collection
    
    ' 初始化工作簿和工作表
    Set wb1 = Workbooks("Merged Data.xlsx")
    Set wb2 = ThisWorkbook
    Set wsHF = wb2.Worksheets("HF")
    Set wsWellcare = wb2.Worksheets("MEMBER_ID")
    Set wsSource1 = wb1.Worksheets("HF1")
    Set wsSource2 = wb1.Worksheets("HF2")
    
    ' 清空目标工作表旧数据
    With wsWellcare
        If .Cells(.Rows.Count, "A").End(xlUp).Row > 1 Then
            .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
        End If
    End With
    
    ' 加载搜索列表到数组（wsHF的C列）
    searchList = wsHF.Range("C2:C" & wsHF.Cells(wsHF.Rows.Count, "C").End(xlUp).Row).Value
    
    ' 初始化字典
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' 忽略大小写，按需调整
    
    ' 加载源工作表1的数据到字典
    LoadSourceDataToDict wsSource1, dict
    ' 加载源工作表2的数据到字典
    LoadSourceDataToDict wsSource2, dict
    
    ' 收集所有匹配的数据到目标数组
    ' 先预估目标数组大小，避免动态扩容
    Dim totalMatches As Long
    totalMatches = 0
    For i = LBound(searchList, 1) To UBound(searchList, 1)
        key = searchList(i, 1)
        If dict.Exists(key) Then
            totalMatches = totalMatches + dict(key).Count
        End If
    Next i
    
    ' 初始化目标数组（5列）
    ReDim targetData(1 To totalMatches, 1 To 5)
    k = 0
    
    ' 遍历搜索列表，提取匹配数据
    For i = LBound(searchList, 1) To UBound(searchList, 1)
        key = searchList(i, 1)
        If key <> "" And dict.Exists(key) Then
            Set matchedRows = dict(key)
            For j = 1 To matchedRows.Count
                k = k + 1
                targetData(k, 1) = matchedRows(j)(1)
                targetData(k, 2) = matchedRows(j)(2)
                targetData(k, 3) = matchedRows(j)(3)
                targetData(k, 4) = matchedRows(j)(4)
                targetData(k, 5) = matchedRows(j)(5)
            Next j
        End If
    Next i
    
    ' 将目标数组写入工作表
    If totalMatches > 0 Then
        wsWellcare.Range("A2:E" & 1 + totalMatches).Value = targetData
    End If
    
    ' 释放对象
    Set dict = Nothing
    Set matchedRows = Nothing
    
    ' 恢复Excel功能
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Cursor = xlDefault
    MsgBox "数据提取完成", vbInformation
End Sub

Sub LoadSourceDataToDict(sourceSheet As Worksheet, dict As Object)
    Dim sourceData As Variant
    Dim i As Long
    Dim key As Variant
    Dim rowData As Variant
    Dim col As Collection
    
    ' 加载源工作表数据到数组（仅前5列）
    sourceData = sourceSheet.Range("A1:E" & sourceSheet.Cells(sourceSheet.Rows.Count, "C").End(xlUp).Row).Value
    
    ' 遍历数组，填充字典
    For i = LBound(sourceData, 1) To UBound(sourceData, 1)
        key = sourceData(i, 3) ' C列作为搜索键
        If key <> "" Then
            ' 把当前行的5列数据存为数组
            rowData = Array(sourceData(i, 1), sourceData(i, 2), sourceData(i, 3), sourceData(i, 4), sourceData(i, 5))
            If dict.Exists(key) Then
                dict(key).Add rowData
            Else
                Set col = New Collection
                col.Add rowData
                dict.Add key, col
            End If
        End If
    Next i
End Sub

额外优化建议 #

• 引用Microsoft Scripting Runtime：在VBA编辑器中，通过工具->引用勾选Microsoft Scripting Runtime，可以使用强类型的Dictionary，性能比CreateObject略高。
• 使用PowerQuery替代VBA：对于大数据量匹配，Excel的PowerQuery（数据->获取和转换数据）内置的合并功能性能远优于VBA，无需编写代码即可完成数据提取，且支持增量更新。
• 避免整列操作：原代码中Columns("C:C")会遍历整列，改用实际数据范围能减少无效遍历。

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