Question

此问题源自请求帮助将所有复选框的标题设置为单元格区域。经过一些反复试验，我已经能够实现这一目标，但出于某种原因，我只能为它们设置标题。

如果他们获取标题的单元格为空白，我还想设置其可见性。我还希望将它们链接到另一个单元格范围（从字幕单元格偏移（0,1）。

如果标题为空白，而不是单元格值为空，则可能最好设置可见性。不确定，但到目前为止我所拥有的是：

以下是设置字幕的代码：

Sub SetCaptions()

Dim Top As Long, Bottom As Long, i As Long, x As Long
Dim AvailableOptions As Range
Dim CompatibleOptions As Range

Top = Range("B:B").Find("Feature Styles", Range("B1")).Row
Bottom = Range("B:B").Find("Feature Options", Range("B" & Top)).Row
Set AvailableOptions = Range("B" & Top + 1, "B" & Bottom - 1)
i = AvailableOptions.Cells.SpecialCells(xlCellTypeConstants).Count
Set CompatibleOptions = Range("P" & Top + 1, "P" & Bottom - 1)
x = CompatibleOptions.Cells.SpecialCells(xlCellTypeConstants).Count

Range("B21").Value = "Avail Options: " & i
Range("P22").Value = "Compat Options: " & x

Dim obj As OLEObject
Dim chkbox As msforms.CheckBox
Dim a As Long
Dim n As Long
Dim c As Range

With ActiveSheet
    b = 0
    For Each obj In ActiveSheet.OLEObjects
    If TypeOf obj.Object Is msforms.CheckBox Then
        b = b + 1
    End If
    Next
    Range("P20").Value = "Checkboxes: " & b
End With




For n = 1 To b
    For Each c In AvailableOptions
        If c.Value <> "" Then
            With ActiveSheet.OLEObjects("CheckBox" & n)
                .Object.Caption = Cells(Top + n, 16)
                .LinkedCell = Cells(Top + n, 17)
            End With
        End If
    Next c
Next n
End Sub

如果它有帮助，这里是用于生成框的代码：

Sub MakeCheckboxes4()
'delete all checkboxes
'create new checkboxes for all values in B
'set captions from P
'hide checkboxes where P is blank

Dim sht As Worksheet
Set sht = ActiveSheet

Dim obj As OLEObject
For Each obj In ActiveSheet.OLEObjects
    If TypeOf obj.Object Is msforms.CheckBox Then
        obj.Delete
    End If
Next

Dim xSize As Integer:    xSize = 2      ' horizontal size (number of cells)
Dim ySize As Integer:    ySize = 1      ' vertical size

Dim t As Range
Set t = sht.Range("R23").Resize(ySize, xSize)

Dim Top As Long, Bottom As Long, i As Long
Dim AvailableOptions As Range, CompatibleOptions As Range
Top = Range("B:B").Find("Feature Styles", Range("B1")).Row
Bottom = Range("B:B").Find("Feature Options", Range("B" & Top)).Row

Set AvailableOptions = Range("B" & Top + 1, "B" & Bottom - 1)
i = AvailableOptions.Count

Dim c As Range

For Each c In AvailableOptions
    If c.Value <> "" Then
    sht.Shapes.AddOLEObject ClassType:="Forms.CheckBox.1", Left:=t.Left, Top:=t.Top, Width:=t.Width - 2, Height:=t.Height
    Set t = t.Offset(ySize)
    End If
Next c
SetCaptions

End Sub

然后连接细胞：

Sub LinkCells()
Dim Top As Long, Bottom As Long

Top = Range("B:B").Find("Feature Styles", Range("B1")).Row
Bottom = Range("B:B").Find("Feature Options", Range("B" & Top)).Row

Dim i As Integer
Dim chk As Variant

i = Top + 1

With Sheets("Sheet1")

    For Each chk In .OLEObjects
        If TypeName(chk.Object) = "CheckBox" Then
            chk.LinkedCell = .Range("Q" & i).Address
             i = i + 1
        End If
    Next

End With
End Sub

隐藏复选框

Sub HideCheckboxes()

Dim Top As Long, Bottom As Long, i As Long, x As Long
Dim AvailableOptions As Range
Dim CompatibleOptions As Range

Top = Range("B:B").Find("Feature Styles", Range("B1")).Row
Bottom = Range("B:B").Find("Feature Options", Range("B" & Top)).Row
Set AvailableOptions = Range("B" & Top + 1, "B" & Bottom - 1)
i = AvailableOptions.Cells.SpecialCells(xlCellTypeConstants).Count
Set CompatibleOptions = Range("P" & Top + 1, "P" & Bottom - 1)
x = CompatibleOptions.Cells.SpecialCells(xlCellTypeConstants).Count



Dim obj As OLEObject
Dim chkbox As msforms.CheckBox
Dim a As Long
Dim n As Long
Dim c As Range

With ActiveSheet
    b = 0
    For Each obj In ActiveSheet.OLEObjects
    If TypeOf obj.Object Is msforms.CheckBox Then
        b = b + 1
    End If
    Next
End With




For n = 1 To b
    If ActiveSheet.OLEObjects("CheckBox" & n).Object.Caption <> "" Then
        ActiveSheet.OLEObjects("checkbox" & n).Visible = True
    Else
        ActiveSheet.OLEObjects("checkbox" & n).Visible = False
    End If
Next n
End Sub

Answer 1

这是链接最终为我工作的复选框的神奇代码

Sub LinkCells()
Dim Top As Long, Bottom As Long

Top = Range("B:B").Find("Feature Styles", Range("B1")).Row
Bottom = Range("B:B").Find("Feature Options", Range("B" & Top)).Row

Dim i As Integer
Dim chk As Variant

i = Top + 1

With Sheets("Sheet1")

For Each chk In .OLEObjects
    If TypeName(chk.Object) = "CheckBox" Then
        chk.LinkedCell = .Range("Q" & i).Address
         i = i + 1
    End If
Next

End With
End Sub

根据范围内的值设置所有复选框的选项

1 个答案: