【发布时间】：2017-10-23 18:27:30
【问题描述】：
这个问题源于请求帮助将所有复选框的标题设置为单元格范围。经过一些试验和错误，我已经能够做到这一点，但由于某种原因，我只能为它们设置标题。
如果他们从中获取标题的单元格是空白的，我还想设置他们的可见性。我还想将它们链接到另一个单元格范围（从标题单元格偏移 (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
【问题讨论】：
-
你能发布创建复选框的代码吗？那可能就是这样做的地方
-
我按照要求用代码更新了它。谢谢回复。我不必每次调用 sub 时都生成这些框。
-
在找到将标题设置为单元格范围的方法后，我再次更新了此内容。现在，我需要设置其他参数，例如：可见性、链接单元格等。无法使其正常工作。在
Sub SetCaptions()的底部，有一条线我试图用于此目的，但它似乎没有做任何事情。.LinkedCell = Cells(Top + n, 17) -
再次更新以分享我登陆的代码，该代码将清除所有复选框，创建新复选框，从一系列单元格值中设置标题，链接到某些单元格，然后隐藏带有空白标题。超级好玩！