Excel VBA优化案例归档代码：动态实现ClearContents操作

问题背景 #

我的Excel表格包含500行案例列表，案例信息位于C列至R列。每行已添加选项按钮，点击可选中对应案例，通过VLOOKUP公式在另一工作表识别选中项。现在需要创建按钮将选中案例移至其他工作表，但现有方法需为每行编写单元格引用，还要写500个ElseIf分支，工作量极大，求程序化简化方案。

原代码（仅写至selection=3） #

Sub Archive_Case()

Dim selection As Integer

selection = Range("Calculations!A2").Value

Dim Workbook As Workbook 'This Workbook
Dim Cases As Worksheet 'Cases Worksheet
Dim Calculations As Worksheet 'Calculations
Dim Dispo As Worksheet 'Dispo

Set Workbook = ThisWorkbook
Set Cases = Workbook.Sheets("Cases")
Set Calculations = Workbook.Sheets("Calculations")
Set Dispo = Workbook.Sheets("Dispo")

If selection = 0 Then

    MsgBox "Select a case that you want to archive."

ElseIf selection = 1 Then

    If MsgBox("Do you really want to archive this case and remove it from this list?", vbYesNo) = vbNo Then Exit Sub

'Copy into Dispo List
    Application.ScreenUpdating = False
        'Dispo.Unprotect
        Worksheets("Calculations").Range("M16:AB16").Copy
        Dispo.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        'Dispo.Protect
    Application.ScreenUpdating = True

'Erase from Case List
    With Cases

    .Select
    .Range("C11:R11").ClearContents
    .Range("C11").Select

    End With

ElseIf selection = 2 Then

    If MsgBox("Do you really want to archive this case and remove it from this list?", vbYesNo) = vbNo Then Exit Sub

'Copy into Dispo List
    Application.ScreenUpdating = False
        'Dispo.Unprotect
        Worksheets("Calculations").Range("M16:AB16").Copy
        Dispo.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        'Dispo.Protect
    Application.ScreenUpdating = True

'Erase from Case List
    With Cases

    .Select
    .Range("C12:R12").ClearContents
    .Range("C12").Select

    End With

ElseIf selection = 3 Then

    If MsgBox("Do you really want to archive this case and remove it from this list?", vbYesNo) = vbNo Then Exit Sub

'Copy into Dispo List
    Application.ScreenUpdating = False
        'Dispo.Unprotect
        Worksheets("Calculations").Range("M16:AB16").Copy
        Dispo.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        'Dispo.Protect
    Application.ScreenUpdating = True

'Erase from Case List
    With Cases

    .Select
    .Range("C13:R13").ClearContents
    .Range("C13").Select

    End With

End If

End Sub

简化解决方案 #

优化后的完整VBA代码 #

Sub Archive_Case()
    Dim selectionNum As Integer
    Dim targetRow As Integer
    Dim wb As Workbook
    Dim wsCases As Worksheet
    Dim wsCalculations As Worksheet
    Dim wsDispo As Worksheet
    
    ' 变量名修改为selectionNum，避免与内置Selection对象重名
    selectionNum = Range("Calculations!A2").Value
    Set wb = ThisWorkbook
    Set wsCases = wb.Sheets("Cases")
    Set wsCalculations = wb.Sheets("Calculations")
    Set wsDispo = wb.Sheets("Dispo")
    
    ' 未选中案例时提示
    If selectionNum = 0 Then
        MsgBox "请选择要归档的案例。"
        Exit Sub
    End If
    
    ' 计算目标行号：selection=1对应行11，以此类推适配500行数据
    targetRow = 10 + selectionNum
    
    ' 确认归档操作
    If MsgBox("确定要归档此案例并从列表中移除吗？", vbYesNo) = vbNo Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    ' 复制选中案例到Dispo工作表
    'wsDispo.Unprotect ' 若工作表有保护，取消注释此行
    wsCalculations.Range("M16:AB16").Copy
    wsDispo.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    'wsDispo.Protect ' 取消保护后记得重新保护，取消注释此行
    
    ' 清空Cases工作表对应行内容
    With wsCases
        .Range("C" & targetRow & ":R" & targetRow).ClearContents
        .Range("C" & targetRow).Select
    End With
    Application.ScreenUpdating = True
End Sub

核心优化点 #

• 消除重复分支：通过targetRow = 10 + selectionNum直接计算对应行号，无需编写500个ElseIf分支，selection=1对应行11，selection=500对应行510，完美适配500行案例。
• 变量名规范：将selection改为selectionNum，避免与VBA内置的Selection对象冲突，减少潜在错误。
• 代码结构精简：把重复的复制、清空逻辑提取为通用代码，仅保留一份，提升代码可读性和维护性。
• 保持性能优化：保留Application.ScreenUpdating = False，避免操作时屏幕闪烁，提升运行效率。

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