Excel VBA需求：归档已解决故障行并清理源表空行

需求说明 #

公司使用「Storingen」（故障表）记录故障信息，故障处理完成后将D列状态改为「Opgelost」（已解决）。需实现一键归档功能，满足以下要求：

• 仅复制故障表中状态为「Opgelost」的行到「Archief」（归档表）的首个空行，无空行产生，归档数据按时间顺序排列（最新数据在底部）
• 删除故障表中已归档的行，仅保留未处理故障，同时清除故障表因删行产生的空行

现有代码问题 #

当前编写的代码仅能全量复制故障表3-100行数据，无法筛选已解决故障，也不能针对性删除对应行，不符合需求：

Sub Archiveer()
    If MsgBox("Wil je deze data archiveren?", vbOKCancel, "Let op!") = vbOK Then
        Sheets("Archief").Unprotect Password:="Smits"
        Worksheets("Storingen").Select
        Range("3:100").Copy
        Worksheets("Archief").Activate
        Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Worksheets("Storingen").Select
        Range("3:100").ClearContents
        Cells(Rows.Count, "A").End(xlUp).Offset(2, 0).Select
        Sheets("Archief").Protect Password:="Smits"
    Else
        Exit Sub
    End If
End Sub

优化后的代码 #

以下是满足需求的VBA代码，加入了筛选、精准复制删除逻辑：

Sub Archiveer()
    Dim wsStoringen As Worksheet, wsArchief As Worksheet
    Dim lastRowStoringen As Long, lastRowArchief As Long
    Dim filterRange As Range, copyRange As Range
    
    ' 确认操作
    If MsgBox("Wil je deze data archiveren?", vbOKCancel, "Let op!") <> vbOK Then Exit Sub
    
    ' 定义工作表对象，避免频繁切换选中状态
    Set wsStoringen = ThisWorkbook.Worksheets("Storingen")
    Set wsArchief = ThisWorkbook.Worksheets("Archief")
    
    ' 解锁归档表
    wsArchief.Unprotect Password:="Smits"
    
    ' 获取故障表最后一行数据的行号
    lastRowStoringen = wsStoringen.Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 设置筛选范围（假设表头在第2行，数据从第3行开始）
    Set filterRange = wsStoringen.Range("A2:D" & lastRowStoringen)
    
    ' 清除现有筛选，重新筛选D列为"Opgelost"的行
    wsStoringen.AutoFilterMode = False
    filterRange.AutoFilter Field:=4, Criteria1:="Opgelost"
    
    ' 获取筛选后的可见数据行（排除表头行）
    On Error Resume Next
    Set copyRange = filterRange.Offset(1, 0).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' 如果有符合条件的行，执行复制和删除操作
    If Not copyRange Is Nothing Then
        ' 获取归档表最后一行，将数据粘贴到下一行
        lastRowArchief = wsArchief.Cells(Rows.Count, "A").End(xlUp).Row
        copyRange.Copy
        wsArchief.Cells(lastRowArchief + 1, "A").PasteSpecial xlPasteValues
        
        ' 删除故障表中已归档的行
        copyRange.EntireRow.Delete
        
        ' 清除故障表的筛选状态
        wsStoringen.AutoFilterMode = False
    End If
    
    ' 重新锁定归档表
    wsArchief.Protect Password:="Smits"
    
    ' 取消复制状态
    Application.CutCopyMode = False
End Sub

代码关键点说明 #

• 避免冗余操作：直接定义工作表对象，替代频繁的Select/Activate，提升代码效率和稳定性
• 精准筛选：通过AutoFilter定位D列状态为「Opgelost」的行，仅处理已解决故障
• 无空行复制：自动定位归档表最后一行，粘贴后保证数据连续无空行
• 安全删除：仅删除筛选出的可见行，保留未处理故障数据
• 自动恢复视图：操作完成后清除故障表的筛选状态，恢复正常显示

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