Excel VBA跨工作表匹配B列值并复制对应行数据问题

原代码的核心问题 #

• 匹配逻辑错误：当前代码只对比Sheet1和Sheet2同一行的B列值，但需求是Sheet1的每个B列值要在Sheet2的整个B列里找匹配项，而非仅同位置行。
• 数据范围被硬限制：手动设置n=1000，1200条数据自然处理不到后面的200条，且硬编码行数完全不灵活。
• 循环逻辑有bug：I = I + 1会强制跳过下一行，直接导致部分数据遗漏。
• 运行效率低下：没关闭屏幕刷新，处理大量数据时容易卡顿假死；且逐个单元格读写的方式速度极慢。

修复后的VBA代码 #

Sub UpdateSheet1FromSheet2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim rng2 As Range
    Dim matchRow As Variant
    
    ' 关闭屏幕刷新，大幅提升运行速度
    Application.ScreenUpdating = False
    
    ' 绑定工作表对象
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 自动获取两个表的实际最后行数（适配任意数据量）
    lastRow1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
    
    ' 定义Sheet2的B列查找范围
    Set rng2 = ws2.Range("B2:B" & lastRow2)
    
    ' 遍历Sheet1的每一行（从第2行开始，假设第1行是表头）
    For i = 2 To lastRow1
        ' 在Sheet2的B列中查找当前Sheet1的B列值
        matchRow = Application.Match(ws1.Cells(i, "B").Value, rng2, 0)
        
        ' 如果找到匹配项
        If Not IsError(matchRow) Then
            ' 整行复制Sheet2对应行的C-E列到Sheet1
            ws1.Range("C" & i & ":E" & i).Value = ws2.Range("C" & (matchRow + 1) & ":E" & (matchRow + 1)).Value
        End If
    Next i
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "数据更新完成！"
End Sub

代码说明 #

• 用Application.Match替代嵌套循环，查找速度更快，适合处理大量数据。
• 自动获取工作表的最后行数，无需硬编码，适配任意数据量。
• 整列范围复制数据，比逐个单元格赋值效率高很多。
• 关闭屏幕刷新避免卡顿，处理完再恢复显示。

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