基于条件的Excel双表合并VBA框架需求

核心需求 #

• 合并两个大型数据集（各90万行、8列），以P列为匹配键
• 执行以下筛选规则，仅保留符合要求的行：
  • 移除表1中E列 = C列的对应行（两表同步移除）
  • 移除满足ABS(C2 - D2*E2) < 0.03的对应行（两表同步移除）

VBA 代码框架 #

Sub MergeAndFilterLargeDatasets()
    '--------------------------
    ' 用户可修改参数
    '--------------------------
    Const ws1Name As String = "表1" ' 第一个数据集工作表名称
    Const ws2Name As String = "表2" ' 第二个数据集工作表名称
    Const outputWsName As String = "筛选结果" ' 输出结果工作表名称
    Const keyCol As String = "P" ' 合并匹配的键列
    ' 表1判断列的列号（根据实际调整，示例中C/D/E对应第3/4/5列）
    Const colC As Integer = 3
    Const colD As Integer = 4
    Const colE As Integer = 5
    Const tolerance As Double = 0.03 ' 规则3的阈值

    '--------------------------
    ' 变量声明
    '--------------------------
    Dim ws1 As Worksheet, ws2 As Worksheet, outputWs As Worksheet
    Dim dict As Object
    Dim lastRow1 As Long, lastRow2 As Long, outputRow As Long
    Dim i As Long, key As String
    Dim valC As Double, valD As Double, valE As Double
    Dim keepRow As Boolean

    '--------------------------
    ' 性能优化设置
    '--------------------------
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    '--------------------------
    ' 绑定工作表
    '--------------------------
    Set ws1 = ThisWorkbook.Worksheets(ws1Name)
    Set ws2 = ThisWorkbook.Worksheets(ws2Name)
    ' 创建输出表（不存在则新建）
    On Error Resume Next
    Set outputWs = ThisWorkbook.Worksheets(outputWsName)
    On Error GoTo 0
    If outputWs Is Nothing Then
        Set outputWs = ThisWorkbook.Worksheets.Add(After:=ws2)
        outputWs.Name = outputWsName
    End If

    '--------------------------
    ' 用字典存储表2数据（快速匹配P列）
    '--------------------------
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow2 = ws2.Cells(ws2.Rows.Count, keyCol).End(xlUp).Row
    ' 遍历表2，以P列值为键存储整行数据
    For i = 2 To lastRow2 ' 假设第一行为表头
        key = Trim(ws2.Cells(i, keyCol).Value)
        If Not dict.Exists(key) Then
            dict(key) = ws2.Range(ws2.Cells(i, 1), ws2.Cells(i, 8)).Value
        End If
    Next i

    '--------------------------
    ' 遍历表1，执行筛选与合并
    '--------------------------
    lastRow1 = ws1.Cells(ws1.Rows.Count, keyCol).End(xlUp).Row
    outputRow = 2 ' 输出表表头行固定为第1行
    ' 复制表头到输出表
    ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, 8)).Copy outputWs.Cells(1, 1)
    ws2.Range(ws2.Cells(1, 2), ws2.Cells(1, 8)).Copy outputWs.Cells(1, 9) ' 表2表头从第9列开始

    For i = 2 To lastRow1
        key = Trim(ws1.Cells(i, keyCol).Value)
        valC = ws1.Cells(i, colC).Value
        valD = ws1.Cells(i, colD).Value
        valE = ws1.Cells(i, colE).Value
        keepRow = True

        ' 规则1：E列等于C列则标记为移除
        If valE = valC Then
            keepRow = False
        End If

        ' 规则2：计算值小于阈值则标记为移除
        If keepRow And Abs(valC - valD * valE) < tolerance Then
            keepRow = False
        End If

        ' 符合条件且表2有匹配项则合并输出
        If keepRow And dict.Exists(key) Then
            ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 8)).Copy outputWs.Cells(outputRow, 1)
            outputWs.Cells(outputRow, 9).Resize(1, 8).Value = dict(key)
            outputRow = outputRow + 1
        End If
    Next i

    '--------------------------
    ' 恢复系统设置
    '--------------------------
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "处理完成！共保留 " & outputRow - 2 & " 行数据。", vbInformation
End Sub

使用提示 #

1. 优先修改代码顶部的用户可修改参数，匹配你的实际工作表名称、列号
2. 确保两个数据集的表头在第一行，数据从第二行开始
3. 运行前建议备份原始数据，避免意外修改
4. 若数据量超出当前内存承载，可考虑拆分数据集分批次处理

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