修改Excel VBA脚本 实现多ID跨表比对提取指定列数据

需求说明 #

• 读取工作表「Theorie」A11:A17区域内的多个ID值，与工作表「DATA」A列（起始单元格为A1）的ID值做匹配比对
• 匹配成功时，提取「DATA」表对应行的B、C、D、E、H、I、J列数据
• 将提取结果粘贴至「Theorie」工作表，粘贴起始位置为B11单元格

原有代码问题 #

原代码逻辑为遍历DATA表A列所有数据，当行J列值等于Theorie表D3单元格值时，复制该行已用区域整行数据粘贴到Theorie表B列首个空行，和目标需求不匹配。

修改后可直接运行的代码 #

Sub Data_uit_DATA_Raadplegen()
    Dim wsData As Worksheet, wsTheorie As Worksheet
    Dim rngSearchIds As Range, rCell As Range, rngDataIdCol As Range
    Dim outRow As Long
    Dim matchCell As Range
    
    ' 绑定工作表对象
    Set wsData = ThisWorkbook.Worksheets("DATA")
    Set wsTheorie = ThisWorkbook.Worksheets("Theorie")
    
    ' 清空Theorie表原有旧结果
    wsTheorie.Range("B11:H17").ClearContents
    
    ' 定义要匹配的ID范围、DATA表ID列范围
    Set rngSearchIds = wsTheorie.Range("A11:A17")
    Set rngDataIdCol = wsData.Range(wsData.Range("A1"), wsData.Range("A1").End(xlDown))
    
    ' 设定输出起始行
    outRow = 11
    
    ' 遍历所有待匹配ID
    For Each rCell In rngSearchIds.Cells
        If Trim(rCell.Value) <> "" Then
            ' 在DATA表A列做精确匹配
            Set matchCell = rngDataIdCol.Find( _
                What:=rCell.Value, _
                LookIn:=xlValues, _
                LookAt:=xlWhole _
            )
            
            ' 匹配成功则提取指定列数据
            If Not matchCell Is Nothing Then
                wsTheorie.Cells(outRow, "B") = wsData.Cells(matchCell.Row, "B")
                wsTheorie.Cells(outRow, "C") = wsData.Cells(matchCell.Row, "C")
                wsTheorie.Cells(outRow, "D") = wsData.Cells(matchCell.Row, "D")
                wsTheorie.Cells(outRow, "E") = wsData.Cells(matchCell.Row, "E")
                wsTheorie.Cells(outRow, "F") = wsData.Cells(matchCell.Row, "H")
                wsTheorie.Cells(outRow, "G") = wsData.Cells(matchCell.Row, "I")
                wsTheorie.Cells(outRow, "H") = wsData.Cells(matchCell.Row, "J")
            End If
        End If
        ' 行号下移，和A列ID位置一一对应
        outRow = outRow + 1
    Next rCell
End Sub

修改点说明 #

• 匹配逻辑替换：移除原有的J列和D3单元格值判断逻辑，改为以Theorie表A11:A17的ID为匹配源，在DATA表A列做全值精确匹配
• 提取范围收窄：不再复制整行已用区域，仅提取需求指定的7列数据，避免多余数据写入
• 粘贴位置固定：从B11单元格开始逐行输出，输出行和A列待匹配ID的行号一一对应，不会出现错位
• 清空范围适配：对应7列7行的结果区域，仅清空B11:H17的旧内容，不会误删其他位置数据

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