VBA匹配值行复制到新工作表失败问题求助

原代码的核心问题 #

• 双层嵌套循环计算量过大：2920 * 24842 ≈ 7200万次循环，导致运行极慢甚至Excel假死，可能让你误以为只输出了最后一行匹配数据
• 逐行复制粘贴操作效率极低，进一步拖慢了执行速度

优化后的代码 #

Sub FindDataFast()
    Dim serialDict As Object
    Dim rawDataArr As Variant
    Dim resultArr As Variant
    Dim rawRowCount As Long, serialRowCount As Long
    Dim i As Long, j As Long, resultRow As Long
    
    ' 初始化字典存储Serials的唯一值
    Set serialDict = CreateObject("Scripting.Dictionary")
    serialDict.CompareMode = vbTextCompare ' 不区分大小写，如需区分可改为vbBinaryCompare
    
    ' 读取Serials工作表A列数据
    With Sheets("Serials")
        serialRowCount = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To serialRowCount
            If Trim(.Cells(i, "A").Value) <> "" Then ' 跳过空单元格
                serialDict(.Cells(i, "A").Value) = True
            End If
        Next i
    End With
    
    ' 读取RawData工作表所有数据到数组
    With Sheets("RawData")
        rawRowCount = .Cells(.Rows.Count, "G").End(xlUp).Row
        rawDataArr = .Range("A1:G" & rawRowCount).Value ' 假设数据到G列，可根据实际调整列数
    End With
    
    ' 初始化结果数组，大小和RawData一致（后续会截断）
    ReDim resultArr(1 To UBound(rawDataArr, 1), 1 To UBound(rawDataArr, 2))
    resultRow = 1
    
    ' 遍历RawData数组，筛选匹配行
    For i = 2 To rawRowCount ' 从第2行开始跳过表头
        If serialDict.Exists(rawDataArr(i, 7)) Then ' 第7列是G列
            resultRow = resultRow + 1
            ' 复制整行数据到结果数组
            For j = 1 To UBound(rawDataArr, 2)
                resultArr(resultRow, j) = rawDataArr(i, j)
            Next j
        End If
    Next i
    
    ' 将结果写入FinalData工作表
    With Sheets("FinalData")
        .Cells.Clear ' 清空原有数据，如需保留可注释此行
        ' 写入表头
        For j = 1 To UBound(rawDataArr, 2)
            resultArr(1, j) = rawDataArr(1, j)
        Next j
        ' 写入筛选后的数据
        .Range("A1").Resize(resultRow, UBound(resultArr, 2)).Value = resultArr
    End With
    
    ' 释放对象
    Set serialDict = Nothing
    MsgBox "数据筛选完成！共找到 " & resultRow - 1 & " 条匹配数据", vbInformation
End Sub

代码说明 #

1. 字典存储匹配值：用字典快速判断RawData的G列值是否在Serials的A列中，时间复杂度从O(n*m)降到O(n+m)
2. 数组批量读写：将数据读取到内存数组中处理，避免频繁读写Excel单元格，这是VBA提升速度的关键
3. 跳过空值：避免Serials中为空的单元格导致误匹配
4. 一次性写入结果：将筛选后的结果数组一次性写入FinalData，比逐行复制粘贴快数百倍

注意事项 #

• 如果你的RawData数据列不止到G列，需要修改rawDataArr = .Range("A1:G" & rawRowCount).Value中的列范围
• 若需要区分大小写匹配，将serialDict.CompareMode = vbTextCompare改为vbBinaryCompare
• 代码会清空FinalData原有数据，如需保留可注释.Cells.Clear这一行

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