Question

我想设置一些代码来复制带复选框的单元格

我有30个复选框

我复制了以下代码并将其修改了30次

毫无疑问这是多余的

每个复选框都在一行上，它将复制的数据在同一行

单击该复选框后，下一个单元格中的行数据将被复制并移动到其他位置

此数据将被转储到同一工作表中的下方某处

我尝试创建了elseif语句，遗憾的是它们无法正常工作

If ThisWorkbook.Worksheets(1).Shapes("Check Box 2").OLEFormat.Object.Value = 1 Then
     Range("f2").Select
     Selection.Cut
     Sheets("Sheet1").Select
     Range("f15").Select
     ActiveSheet.Paste
     Range("f15").Select
     Selection.Insert Shift:=xlDown    
     End If
     End Sub

If ThisWorkbook.Worksheets(1).Shapes("Check Box 3").OLEFormat.Object.Value = 1 Then
     Range("f3").Select
     Selection.Cut
     Sheets("Sheet1").Select
     Range("f15").Select
     ActiveSheet.Paste
     Range("f15").Select
     Selection.Insert Shift:=xlDown    
     End If
     End Sub

If ThisWorkbook.Worksheets(1).Shapes("Check Box 4").OLEFormat.Object.Value = 1 Then
     Range("f4").Select
     Selection.Cut
     Sheets("Sheet1").Select
     Range("f15").Select
     ActiveSheet.Paste
     Range("f15").Select
     Selection.Insert Shift:=xlDown    
     End If
     End Sub

你可以看到它是非常重复的

关于如何编写此代码的任何建议，以便它就像嵌套的if语句

如果复选框1为真，请执行此操作如果复选框2为真，请执行此操作等等

[IMG] http://i44.tinypic.com/2db78dj.jpg [/ IMG]

请告知谢谢

Answer 1

在不了解工作簿结构的情况下，这是我能想到的最好的结果。这可能是CheckBoxes和需要操作的单元之间的某种“关系”，这可能允许您使用公式或其他逻辑来确定要剪切/粘贴的单元格，而不是依赖于If / Then或Case逻辑。

Sub Test()

Dim cb As Shape
Dim cutRange As Range
'## The destination doesn't change, so we put this outside the loop
'    also make it a constant value:
Cosnt destRange As String = "F15"

'## Now, iterate over each checkbox control in the sheet:
For Each cb In ActiveSheet.Shapes
    '## Make sure the shape is an xlCheckBox AND value = True/checked
    If cb.FormControlType = xlCheckBox And cb.OLEFormat.Object.Value = 1 Then
        '## Assign the cutRange based on the CheckBox name
        Select Case cb.Name
            Case "Check Box 2"
                Set cutRange = Range("F3")
            Case "Check Box 3"
                Set cutRange = Range("F4")
            Case "Check Box 4"
                Set cutRange = Range("F5")
            'etc.

            '## You can add as many Case values as you need
        End Select

        '## One statement cuts & inserts:
        cutRange.Cut Range(destRange)
        Range(destRange).Insert Shift:=xlDown

    End If
Next
End Sub

Excel如果使用复选框复制数据的其他声明

1 个答案: