主页 / coding / 问题 / 79213081
Accepted
DocBrown
Asked: 2024-11-22 06:23:14 +0800 CST

Excel VBA 动态清除内容

  • 772

我的 Excel 电子表格是一份案件清单。共有 500 行，案件信息范围从 C 列到 R 列。

我为每一行创建了选项按钮，这样我可以通过单击该选项按钮来“选择”一个案例。我的 VLOOKUP 公式根据我的选择在另一张表中识别出正确的案例。

现在，我正在尝试创建一个按钮，允许我将选定的案例从电子表格移动到另一张表格上。我知道如何做到这一点，但我的方法非常麻烦，因为它要求我输入每行的单元格引用。一共有 500 个单元格引用，所以这会花很长时间。有没有办法以编程方式加快这一过程？

这是我实现所需结果的方法，但耗时太长。如您所见，我在“ElseIf Selection = 3”之后停了下来，因为我意识到我必须这样做 500 次。我宁愿不必输入 500 个“ElseIf Selection = ”条目并更改下面“从案例列表中删除”部分中的单元格引用。有什么解决方案吗？

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
excel

1 个回答

  1. Best Answer

    不需要所有这些情况：

    Sub Archive_Case()
    'Ideally don't name variables with the same name as existing items/types
    '    like Selection, Workbook, etc
    Dim wb As Workbook, CaseNum As Long 'prefer long over integer
    Dim Cases As Worksheet, Calculations As Worksheet, Dispo As Worksheet
    
    Set wb = ThisWorkbook
    Set Cases = wb.Worksheets("Cases")
    Set Calculations = wb.Worksheets("Calculations")
    Set Dispo = wb.Worksheets("Dispo")
    
    CaseNum = Calculations.Range("A2").Value
    
    If CaseNum = 0 Then
        MsgBox "First select a case that you want to archive."
        Exit Sub
    Else
        If MsgBox("Do you really want to archive this case " & _
            "and remove it from this list?", vbYesNo) <> vbYes Then Exit Sub
               
        With Calculations.Range("M16:AB16") 'copy case info from the lookup range
            Dispo.Cells(Rows.Count, "C").End(xlUp). _
              Offset(1, 0).Resize(1, .Columns.Count).Value = .Value
        End With
        
        With Cases.Range("C10:R10").Offset(CaseNum) 'clear the case
            .ClearContents
            .Cells(1).Select
        End With
               
    End If

End Sub

    不过，管理每行的选项按钮有点麻烦，所以您可以考虑在每行上添加一个“存档”超链接，然后使用该链接触发存档（使用Worksheet.FollowHyperlink事件运行复制/清除步骤）

    • 3

相关问题