VBA代码优化求助：如何实现Sheet2逐行写入匹配结果？

问题根源 #

1. 写入Sheet2时固定使用第2行（如Sheet2.Range("C2")），导致每次都覆盖同一行数据
2. lRow变量未关联到写入的行号，且更新逻辑错误（无论是否找到匹配都执行lRow +=1）
3. 未明确指定Cells(i,15)所属工作表，存在引用错误风险

修改后的完整代码 #

Sub Induction_Report2()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Sheet2.Rows("2:" & Rows.Count).ClearContents

    Dim s As Range
    Dim i As Integer
    Dim lRow As Long
    
    ' 初始化写入起始行：Sheet2清空后，从第2行开始写入（假设第1行是表头）
    lRow = 2

    For i = 79 To 6256
        ' 明确指定Sheet17的单元格，避免引用当前激活表
        If Sheet17.Cells(i, 15) <> "" Then
            Set s = Sheet1.Range("A1:A9000").Find( _
                What:=Sheet17.Cells(i, 15).Value, _
                LookAt:=xlWhole, _
                MatchCase:=False, _
                SearchFormat:=False)
            
            If s Is Nothing Then ' 未找到匹配值时写入数据
                Sheet2.Range("C" & lRow).Value = Sheet17.Cells(i, 11).Value ' 姓名
                Sheet2.Range("B" & lRow).Value = Sheet17.Cells(i, 14).Value ' 角色
                Sheet2.Range("D" & lRow).Value = Sheet17.Cells(i, 12).Value ' 供应商
                Sheet2.Range("A" & lRow).Value = Sheet17.Cells(i, 16).Value ' 工号
                
                ' 只有写入数据后，才将下一行设为新的写入行
                lRow = lRow + 1
            End If
        End If
    Next i
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

关键修改说明 #

• 初始化lRow：因为Sheet2的第2行及以下已被清空，直接将起始行设为2（若第1行无表头，可设为1）
• 动态指定写入行：将固定的2替换为lRow，如Sheet2.Range("C" & lRow)，实现每次写入对应行
• 调整lRow更新时机：仅在成功写入数据后执行lRow +=1，确保下一次写入自动切换到下一行
• 明确工作表引用：将Cells(i,15)改为Sheet17.Cells(i,15)，避免因当前激活表变化导致的引用错误

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