excel 產生多個核取方塊. - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » excel 產生多個核取方塊.

返回列表下一主題上一主題發帖

excel 產生多個核取方塊.

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2013-9-5 15:58 | 顯示全部帖子

回復 3# sworder12
2003版可用

Option Explicit
Sub Ex()
Dim S As Integer, C As Variant
For Each C In ActiveSheet.OLEObjects
If C.Name Like "CheckBox*" Then
S = S + IIf(C.Object.Value, 1, 0)
End If
Next
MsgBox S
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2013-9-5 16:49 | 顯示全部帖子

回復 5# ML089

Option Explicit
Sub Ex()
Dim S As Integer, C As Variant
For Each C In ActiveSheet.OLEObjects '控制工具箱的控制項 (MSForms.CheckBox)
If C.Name Like "CheckBox*" Then
S = S + IIf(C.Object.Value, 1, 0)
End If
Next
MsgBox S
S = 0
For Each C In ActiveSheet.CheckBoxes '表單的控制項(核取方塊)
S = S + IIf(C.Value = 1, 1, 0)
Next
MsgBox S
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2013-9-5 20:07 | 顯示全部帖子

回復 7# ML089
控制工具箱的控制項,可寫VBA

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2013-9-6 07:02 | 顯示全部帖子

回復 12# ML089

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

5^#

發表於 2013-9-8 13:56 | 顯示全部帖子

回復 18# sworder12
最後跳出小視窗顯示一個「 0 」請附檔看看
解決造成兩個核取方塊重疊.的程式碼

Option Explicit
Sub Ex()
Dim C As Variant, B As Object, I As Integer, Rng(1 To 2) As Range
With ActiveSheet
Set Rng(1) = .Range("A:A").SpecialCells(2) '處裡 A欗有資料的文字的 CheckBoxe
If .CheckBoxes.Count > 1 Then
For Each C In .CheckBoxes
If Not Intersect(C.TopLeftCell.Offset(, -1), Rng(1).EntireColumn) Is Nothing Then
If C.TopLeftCell.Offset(, -1) = "" Then
C.TopLeftCell.Offset(, 1) = ""
C.Delete
Else
C.Characters.Text = C.TopLeftCell.Offset(, -1)
If Rng(2) Is Nothing Then
Set Rng(2) = C.TopLeftCell.Offset(, -1)
Else
Set Rng(2) = Union(Rng(2), C.TopLeftCell.Offset(, -1)) '.Offset(, -1)
End If
End If
End If
Next
End If
For Each C In Rng(1) 'Rng(2): CheckBoxe 的TopLeftCell儲存格
If Rng(2) Is Nothing Then
Set B = .CheckBoxes.Add(C(1, 2).Left, C.Top, C.Width, C.Height)
B.Characters.Text = C
B.LinkedCell = C.Offset(, 2).Address
ElseIf Intersect(C, Rng(2)) Is Nothing Then
Set B = .CheckBoxes.Add(C(1, 2).Left, C.Top, C.Width, C.Height)
B.Characters.Text = C
B.LinkedCell = C.Offset(, 2).Address
End If
Next
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 難行能行，難捨能捨，難為能為，才能昇華自我的人格。

返回列表下一主題上一主題