使用VBA按条件复制多行数据到其他工作表仅返回部分结果问题咨询

问题原因 #

• 粘贴位置定位错误：Else分支中错误将源工作表Sheet1作为查找粘贴位置的对象，而非目标工作表Sheet5，后续匹配到的记录全部粘贴到了源表而非目标表，最终目标表仅能保留少数初始匹配的记录。
• 遍历范围写死：状态列的扫描范围固定为E2:E22，新增数据超出22行后，新增的符合条件的记录不会被识别和迁移。
• 定位逻辑缺陷：使用End(xlDown)从表头向下查找最后一行，若列中存在空行，会误将空行上方识别为最后一行，导致粘贴位置错位、内容覆盖。
• 无重复数据处理逻辑：多次运行代码会重复粘贴记录，也会干扰最终结果展示。

修复后代码 #

Sub CopyShipmentRecords()
    Dim StatusCol As Range
    Dim Status As Range
    Dim PasteCell As Range
    Dim LastRow As Long
    
    ' 动态获取源表E列最后一行有数据的行号，适配新增数据
    LastRow = Sheet1.Cells(Sheet1.Rows.Count, "E").End(xlUp).Row
    Set StatusCol = Sheet1.Range("E2:E" & LastRow)
    
    ' 可选：运行前清空目标表原有迁移结果，避免重复粘贴，不需要可删除此行
    Sheet5.Range("C2:G" & Sheet5.Cells(Sheet5.Rows.Count, "C").End(xlUp).Row).ClearContents
    
    For Each Status In StatusCol
        ' 从目标表C列底部向上查找最后一个非空行，偏移1行作为粘贴位置，适配空表、有中间空行的场景
        Set PasteCell = Sheet5.Cells(Sheet5.Rows.Count, "C").End(xlUp).Offset(1, 0)
        ' 排除空值避免无效匹配
        If Not IsEmpty(Status) And Status.Value = "shipment oi" Then
            Status.Offset(0, -2).Resize(1, 5).Copy PasteCell
        End If
    Next Status
            
End Sub

修改说明 #

• 修正了粘贴位置的工作表引用，全部使用目标表Sheet5做定位，解决核心的粘贴位置错误问题
• 改用动态范围扫描源数据，后续新增数据无需手动修改代码范围
• 调整粘贴位置查找逻辑为从下往上定位，规避空行导致的定位错误，同时省略了冗余的空表判断逻辑，空表时该方法会自动定位到C2
• 新增可选的历史数据清空逻辑，避免多次运行产生重复记录

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