基于单个单元格值从参考表填充行内多单元格的VBA实现问题

实现逻辑：

• 关联规则：以Base Data工作表（table1）C列值为匹配键，匹配Procedures工作表（table2）的首列值
• 填充规则：匹配成功后，将table2对应行B_{H列的7项数据，同步写入table1当前行的D}J列
• 兼容处理：未匹配到的行默认填充标识，不会覆盖原有无关数据

修改后代码 #

Sub 匹配填充数据()
    Dim wsTarget As Worksheet ' table1所在工作表：Base Data
    Dim wsSource As Worksheet ' table2所在工作表：Procedures
    Dim tblTarget As ListObject ' table1表对象
    Dim tblSource As ListObject ' table2表对象
    Dim matchKey As String ' 匹配关键字
    Dim i As Long, j As Long ' 循环变量
    Dim keyCol As Long ' table2匹配键所在列，默认首列=1
    keyCol = 1
    
    ' 初始化工作表对象
    Set wsTarget = Worksheets("Base Data")
    Set wsSource = Worksheets("Procedures")
    ' 初始化表对象，按需调整表名
    Set tblTarget = wsTarget.ListObjects("quals")
    Set tblSource = wsSource.ListObjects(1)
    
    ' 遍历table1所有数据行
    For i = 1 To tblTarget.ListRows.Count
        ' 取当前行C列（第3列）作为匹配关键字
        matchKey = tblTarget.ListRows(i).Range(3).Value
        If matchKey <> "" Then
            ' 遍历table2匹配关键字
            For j = 1 To tblSource.ListRows.Count
                If tblSource.ListRows(j).Range(keyCol).Value = matchKey Then
                    ' 匹配成功，批量写入B~H列到D~J列
                    tblTarget.ListRows(i).Range(4).Resize(1, 7).Value = _
                    tblSource.ListRows(j).Range(2).Resize(1, 7).Value
                    Exit For ' 匹配到即退出内层循环
                End If
                ' 未匹配到的情况，按需修改填充内容
                If j = tblSource.ListRows.Count Then
                    tblTarget.ListRows(i).Range(4).Value = "无匹配数据"
                End If
            Next j
        End If
    Next i
    
    ' 释放对象
    Set tblSource = Nothing
    Set tblTarget = Nothing
    Set wsSource = Nothing
    Set wsTarget = Nothing
End Sub

注意事项 #

• 如果table2的匹配键不是首列，修改keyCol = 1为对应列序号即可
• 未匹配填充内容可自行修改tblTarget.ListRows(i).Range(4).Value = "无匹配数据"行，设置为空值可改为= ""
• 如果两个工作表存在多个表需要批量处理，可在外层套入原代码的表遍历循环即可

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