VBA实现跨表匹配指定字符串后复制符合条件的指定区域行数据

原代码存在的问题 #

• 匹配值引用错误：直接将字符串"D1"作为匹配判断值，没有正确读取test2工作表D1单元格的实际存储内容
• 遍历范围不合理：选择整列H:H做循环，会遍历所有空行、表头行，运行效率低还容易出现误匹配
• 复制范围逻辑错误：使用Cell.Range()的相对引用写法，无法正确定位匹配行对应的目标列区域
• 粘贴范围逻辑错误：通过行号拼接M列范围的写法存在语法问题，没有跟踪目标表的粘贴位置，会出现数据错位、覆盖问题

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

Sub Test()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow As Long, destRow As Long
    Dim matchVal As String
    Dim cell As Range
    
    ' 绑定工作表对象，简化后续引用
    Set ws1 = ThisWorkbook.Sheets("test1")
    Set ws2 = ThisWorkbook.Sheets("test2")
    
    ' 正确读取test2表D1单元格的匹配关键词
    matchVal = CStr(ws2.Range("D1").Value)
    ' 设定test2表粘贴起始行为M3对应的行号
    destRow = 3
    
    ' 定位test1表H列最后一行有效数据的行号
    lastRow = ws1.Range("H" & ws1.Rows.Count).End(xlUp).Row
    
    ' 仅遍历test1表H3开始的有效数据区域，不遍历整列
    For Each cell In ws1.Range("H3:H" & lastRow)
        ' 统一转文本格式做匹配，避免格式差异导致匹配失败
        If CStr(cell.Value) = matchVal Then
            ' 复制当前行指定列区域：如果需要复制E:H列，把下面代码里的C改成E即可
            ws1.Range("C" & cell.Row & ":H" & cell.Row).Copy
            ' 按值粘贴到test2表对应位置
            ws2.Range("M" & destRow).PasteSpecial xlPasteValues
            ' 粘贴位置下移一行，避免覆盖已有数据
            destRow = destRow + 1
        End If
    Next
    
    ' 清除剪贴板复制状态
    Application.CutCopyMode = False
End Sub

关键写法说明 #

• 跨表单元格取值格式：工作表对象.Range("单元格地址").Value，例如此处取test2表D1值的写法为Sheets("test2").Range("D1").Value，禁止给单元格地址加引号作为字符串判断
• 单行多列区域定位：匹配到目标行后，用列标 & 行号 & :列标 & 行号的格式拼接范围地址，不要用相对偏移的Range写法
• 顺序粘贴逻辑：单独维护目标表的粘贴行号变量，每粘贴一行变量自增1，保证数据依次排列不重叠
• 格式兼容：对比单元格值时统一用CStr()转为文本类型，避免数值、文本格式不一致导致匹配漏项

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