Excel VBA 按A列参考编号筛选转移指定行列到存档表并删除原行

修正后完整代码 #

Sub Archiv()
    Dim Zeile As Long
    Dim ZeileMax As Long
    Dim Bereich As Range
    
    With Sheets("Protokoll")
        ZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        For Zeile = 6 To ZeileMax
            If .Cells(Zeile, 1).Value = Userform_boxnumber.Value Then
                If Bereich Is Nothing Then
                    ' 初始化匹配区域，限定取当前行A-K列（共11列）
                    Set Bereich = .Cells(Zeile, 1).Resize(1, 11)
                Else
                    ' 追加新的匹配行A-K列到汇总区域
                    Set Bereich = Union(Bereich, .Cells(Zeile, 1).Resize(1, 11))
                End If
            End If
        Next Zeile
        
        ' 仅存在匹配行时执行操作，避免空值报错
        If Not Bereich Is Nothing Then
            ' 复制到存档表：当前代码为自动粘贴到存档表A列首个空行，如需固定粘贴到A3可改回 Range("A3")
            Bereich.Copy Destination:=Sheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            ' 删除原表匹配行
            Bereich.EntireRow.Delete
        End If
    End With
End Sub

调整点说明 #

• 恢复了原代码中被注释的匹配区域收集逻辑，将原整行引用.Rows(Zeile)调整为.Cells(Zeile, 1).Resize(1, 11)，限定只读取A-K列内容，解决复制全列的问题
• 补充了区域非空校验逻辑，避免未匹配到对应参考编号时触发空对象报错
• 新增Bereich.EntireRow.Delete语句，复制完成后直接删除原表中匹配的对应行
• 可选优化：默认调整为存档表自动追加内容不覆盖已有数据，如有固定覆盖A3开始区域的需求，修改粘贴目标参数即可

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