0

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

我有 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]

请指教谢谢

4

1 回答 1

0

在不了解工作簿结构的情况下，这是我能想到的最好的。复选框和需要操作的单元格之间可能存在某种“关系”，这可以让您使用公式或其他逻辑来确定要剪切/粘贴的单元格，而不是依赖于如果/那么或案例逻辑。

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
于 2013-09-16T01:43:30.513 回答