Excel VBA 按多条件复制整行时粘贴位置错误及覆盖问题如何解决

'Sheet1 is named Template1
'Sheet2 is named Copy data
Sub 复制符合条件行()
    Dim srcSht As Worksheet, tgtSht As Worksheet
    Dim lastRowSrc As Long, lastRowTgt As Long, i As Long
    
    ' 定义工作表对象，避免频繁切换工作表
    Set srcSht = ThisWorkbook.Worksheets("Template1")
    Set tgtSht = ThisWorkbook.Worksheets("Copy data")
    
    ' 获取源表最后一行行号
    lastRowSrc = srcSht.Cells(srcSht.Rows.Count, 1).End(xlUp).Row
    
    ' 先判断目标表34行及以下的最后一行，确保起始粘贴位置不低于34行
    If tgtSht.Cells(tgtSht.Rows.Count, 1).End(xlUp).Row < 34 Then
        lastRowTgt = 33 ' 第一次粘贴从34行开始，所以+1后是34
    Else
        lastRowTgt = tgtSht.Cells(tgtSht.Rows.Count, 1).End(xlUp).Row
    End If
    
    ' 遍历源表行
    For i = 34 To lastRowSrc
        ' 修正判断条件：同时匹配数值≥1 或 值为"x"的情况，兼容大小写
        If srcSht.Cells(i, 15) >= 1 Or UCase(srcSht.Cells(i, 15).Value) = "X" Then
            ' 直接复制，不需要激活切换工作表
            srcSht.Rows(i).Copy tgtSht.Rows(lastRowTgt + 1)
            ' 粘贴后目标行号+1，避免覆盖
            lastRowTgt = lastRowTgt + 1
        End If
    Next
    
    ' 修正拼写错误
    Application.CutCopyMode = False
    srcSht.Activate
    srcSht.Cells(1, 1).Select
End Sub

• 调整判断逻辑：新增了对O列值为x的匹配规则，兼容大小写输入，符合需求的筛选条件
• 修复粘贴起始位置问题：新增逻辑判断目标表的粘贴起始行，确保第一行符合条件的内容默认粘贴到Copy data的第34行
• 解决x行粘贴覆盖问题：不再在每次循环时重新查找目标表最后一行，改为预计算后每次粘贴手动递增行号，避免部分行A列为空时End(xlUp)定位错误导致的覆盖问题
• 优化运行效率：取消了循环内频繁切换激活工作表的操作，代码运行更流畅
• 修复了原代码中Apllication的拼写错误，避免运行报错

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