在 VBA Excel 中使用带有复选框的“if.....then”循环

Question

我正在创建一个 VBA Excel 程序，如果选中了相应的复选框，我可以将单元格值复制到另一个工作表。我在一列中有 278 个“数字”条目，在一列中有一个相应的单个“复选框”。但是当单击复选框时，不显示相应的行文本。而是仅显示前 5 列值。例如，如果我随机选择 5 个复选框，则显示“工作表 2”列中显示 1、2、3、4、5 个数字。

Sub Button21_Click()
    Dim chkbx As CheckBox
    Dim i As Integer
    a = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To a
        For Each chkbx In ActiveSheet.CheckBoxes
            If chkbx.Value = xlOn Then
                Worksheets("sheet1").Cells(i, 1).Copy
                Worksheets("sheet2").Activate
                b = Worksheets("sheet2").Cells(i, 1).End(xlUp).Row
                Worksheets("sheet2").Cells(b + 1, 1).Select
                ActiveSheet.Paste
                i = i + 1
            End If
        Next chkbx
    Next i
End Sub

这是我使用的代码。 任何帮助将不胜感激。

Answer 1

物品调查

解决方案

TopLeftCell 解决方案， 解决方案，基于 cmets 中建议的Tim Williams 思路。

这将在您的工作表代码中 (Sheet1)。

Sub Button21_Click()
    executeCheckBoxes
End Sub

其余的将在标准模块中（例如Module1）。

Sub executeCheckBoxes()

    Dim src As Worksheet     ' Source Worksheet (Object)
    Dim tgt As Worksheet     ' Target Worksheet (Object)
    Dim chkbx As CheckBox    ' CheckBox (For Each Control Variable)
    Dim srcLR As Long        ' Source Last Row
    Dim tgtER As Long        ' Target Empty Row
    Dim i As Long            ' Source Row Counter

    Set src = ThisWorkbook.Worksheets("Sheet1")
    Set tgt = ThisWorkbook.Worksheets("Sheet2")
    srcLR = src.Cells(src.Rows.Count, 1).End(xlUp).Row
    tgtER = tgt.Cells(tgt.Rows.Count, 1).End(xlUp).Row + 1

    For Each chkbx In src.CheckBoxes
        If chkbx.Value = xlOn Then
        ' Cell Version
            tgt.Cells(tgtER, 1).Value = _
              src.Cells(chkbx.TopLeftCell.Row, 1).Value
        ' The following 2 ideas are not so good. They are running into trouble
        ' when adding new checkboxes if not sooner.
        ' Index Version
            ' Assuming the index of the checkbox is 1 for row 2, 2 for 3 etc.
            ' Adjust the "+1" as needed.
'            tgt.Cells(tgtER, 1).Value = src.Cells(chkbx.Index + 1, 1).Value
        ' Name Version
            ' Assuming the name of the checkbox is "Check Box 1" for row 2,
            ' "Check Box 2" for 3 etc. Adjust the "+1" as needed.
'            tgt.Cells(tgtER, 1).Value = src.Cells(Val(Right(chkbx.Name, _
'                Len(chkbx.Name) - Len("Check Box "))) + 1, 1).Value
            tgtER = tgtER + 1
            Debug.Print chkbx.Name
        End If
    Next chkbx

End Sub

附加功能

以下是用于帮助创建两个劣等解决方案的代码。

Sub deleteCB()
    deleteCheckBoxes ThisWorkbook.Worksheets("Sheet1")
End Sub

' Deletes all check boxes on a worksheet.
' Note: When you delete all check boxes, the 'counter' is not reset i.e. if you
'       e.g. had "Check Box 100" the next check box will be named "Check Box 101".
'       But after you save and close the workbook and open it again,
'       the first check box name will be "Check Box 1".
Sub deleteCheckBoxes(Sheet As Worksheet)
    Sheet.CheckBoxes.Delete
End Sub

' Creates check boxes in a range.
Sub addCheckBoxes()
    Const SheetName As String = "Sheet1"
    Const chkRange As String = "B2:B279"
    Const chkCaption As String = "Chk"
    Dim chk As CheckBox, rng As Range, cel As Range, i As Long
    i = 1
    With ThisWorkbook.Worksheets(SheetName)
        Set rng = .Range(chkRange)
        For Each cel In rng.Cells
            Set chk = .CheckBoxes.Add(cel.Left, cel.Top, cel.Width, cel.Height)
            With chk
                .Caption = chkCaption & i
            End With
            i = i + 1
        Next
    End With
End Sub

Sub showSomeCheckBoxProperties()
    Dim chk As CheckBox, rng As Range, cel As Range, i As Long
    i = 1
    With ThisWorkbook.Worksheets("Sheet1")
        For Each chk In .CheckBoxes
            With chk
                Debug.Print .BottomRightCell.Address, .Caption, _
                  .Characters.Count, .Enabled, .Index, .Name, .Placement, _
                  .Text, .TopLeftCell.Address, .Value, .Visible
            End With
        Next
    End With
End Sub

附加 2

以下是基于 YouTube 视频的代码 Add Button to Worksheet and Assign a Macro to it -Excel Help by XLorate 对回答这个问题很有帮助。

Sub addButtons()
    Dim btn As Button, rng As Range, cel As Range, i As Long
    i = 1
    With ThisWorkbook.Worksheets("Sheet1")
        Set rng = .Range("A1:A3")
        For Each cel In rng.Cells
            Set btn = .Buttons.Add(cel.Left, cel.Top, cel.Width, cel.Height)
            With btn
                .Caption = "Macro" & i
                .OnAction = "Macro" & i
            End With
            i = i + 1
        Next
    End With
End Sub

以下是我在调查对象时创建的其他或多或少有用的代码。

Sub showSomeShapesProperties()
    Dim ws As Worksheet, sh As Shape
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For Each sh In ws.Shapes
        With sh
            If sh.Type = 12 Then
                Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
            End If
            If sh.Type = 8 Then
                Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
            End If
        End With
    Next
End Sub

Sub showSomeOleObjectProperties()
    Dim ws As Worksheet, oo As OLEObject
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For Each oo In ws.OLEObjects
        With oo
            Debug.Print .Name, .OLEType, .AutoLoad, .Enabled, .Index, _
              .BottomRightCell.Address
        End With
    Next
End Sub

Sub addOLECheckBoxes()
    Const srcName As String = "Sheet1"
    Dim chk As OLEObject, rng As Range, cel As Range, i As Long
    With ThisWorkbook.Worksheets(srcName)
        Set rng = .Range("A1:A10")
        i = 1
        For Each cel In rng.Cells
            Set chk = .OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
              Left:=cel.Left, Top:=cel.Top, Width:=cel.Width, Height:=cel.Height)
            With chk
                '.Name = "Chk" & i
                '.Placement = xlMoveAndSize

            End With
            i = i + 1
        Next cel
    End With
End Sub