Question

Dim t As Long
Dim u As Long
Dim v As Long
Dim q As Long
Dim p As Long
t = 1
u = 1    
  Do
    If Sheet2.Range("D" & t).Value = "" Then
      If Sheet2.Range("D" & t + 1).Value = "" Then
        If Sheet2.Range("D" & t + 2).Value = "" Then
          If Sheet2.Range("D" & t + 3).Value = "" Then
            If Sheet2.Range("D" & t + 4).Value = "" Then
              If Sheet2.Range("C" & t).Value = "" Then
                Exit Do
              End If
            End If
          End If
        End If
      End If
    End If
    If Not Sheet2.Range("D" & t).Value = "" Then
      If Not Sheet2.Range("D" & t).Value = "Description" Then
        v = Sheet2.Range("A" & 1 & ":" & "A" & t - 1).Height
        q = Sheet2.Range("A" & t).Height
        p = v + (q / 2) - 5
        Set obj = Sheet2.OLEObjects.Add("Forms.checkbox.1")
        With obj
          .Width = 10
          .Top = p
          .Left = 875
          .Height = 10
        End With
        u = u + 1
      End If
    End If
    t = t + 1
  Loop

此代码将帮助我根据我的要求创建许多active-x复选框，如图所示。

检查图像后，单击必要的复选框，然后按下命令按钮＆＃34;导出nfr＆＃34;，对应所选复选框的行应该复制到另一张表，有什么办法吗？添加该操作的代码

抱歉编辑问题

https://i.stack.imgur.com/YF2U2.png

Answer 1

使用“自定义”复选框，通过创建事件sunk类，例如clsCustomCheckBox

Option Explicit

Public WithEvents cb As msforms.CheckBox

Public Sub init(cbInit As msforms.CheckBox)
     Set cb = cbInit
End Sub

Private Sub cb_Click()     ' or the _Change event....
    '   Your code here
End Sub

然后你可以添加新的，然后做类似下面的事情

Private c As Collection

Sub testcb()

Dim o As Object
Dim cb As New clsCustomCheckBox

Set o = ActiveSheet.OLEObjects(1)

cb.init o.Object

Set c = New Collection
c.Add cb

End Sub

Answer 2

您可以切换为Form Control而不是ActiveX，并利用其OnAction属性并为所有复选框指定相同的子

如下：

Sub Macro2()
    Dim t As Long, u As Long, v As Long, q As Long, p As Long

    t = 2 '<--| start from 2 otherwise subsequent "A" & (t - 1) would return "A0"!
    u = 1
    With Sheet2
        Do
            If WorksheetFunction.CountA(.Cells(t, "D").Resize(5), .Cells(t, "C")) < 6 Then Exit Do

            If Not .Cells(t, "D").Value = "Description" Then
                v = .Range("A1", "A" & (t - 1)).Height
                q = .Cells(t, "A").Height
                p = v + (q / 2) - 5
                With .CheckBoxes.Add(875, p, 10, 10) '<--| add a 'Form' checkbox
                    .OnAction = "CheckBoxClick" '<--| current checkbox will "react" calling 'CheckBoxClick()' sub
                End With
                u = u + 1 '<--| what is this for?
            End If
            t = t + 1
        Loop
    End With
End Sub

然后您只需键入CheckBoxClick()子，例如：

Sub CheckBoxClick()
    With ActiveSheet.CheckBoxes(Application.Caller) '<--| reference caller checkbox
        MsgBox "hello from " & .Name & " place at cell " & .TopLeftCell.Address
    End With
End Sub

使用vba

2 个答案: