excel超軽量チェックボックス
動画を見る##ダブルクリックイベントで文字入れ替え
値の取得は、=if(G2="þ",1,0) で簡単に取れます。"þ"は、数式バーに表示される文字をそのまま式に使う。
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
'複数セル選択は処理対象外
If target.Count > 1 Then Exit Sub
' チェックボックス ON:ChrW(254) ←→ OFF:ChrW(111)
If target.Value = ChrW(111) Or target.Value = ChrW(254) Then
If target.Value = ChrW(111) Then target.Value = ChrW(254) Else target.Value = ChrW(111)
cancel = True ' ダブルクリック動作をキャンセル
Exit Sub
End If
End Sub
##シングルクリックも考えてみる
Excelには、クリックイベントが無い(簡単には使えない)ので中途半端なものになりました。
一応シングルクリック対応しましたが、矢印キーでセル移動しても動作する。
セル選択状態ではイベントが発生しない。
ダブルクリックすると、イベントが2回発生して、元の状態になる。
使えない事はないけど。。。。
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Dim cancel As Boolean
Call Worksheet_BeforeDoubleClick(target, cancel)
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean)
'複数セル選択は処理対象外
If target.Count > 1 Then Exit Sub
' チェックボックス ON:ChrW(254) ←→ OFF:ChrW(111)
If target.Value = ChrW(111) Or target.Value = ChrW(254) Then
If target.Value = ChrW(111) Then target.Value = ChrW(254) Else target.Value = ChrW(111)
cancel = True ' ダブルクリック動作をキャンセル
Exit Sub
End If
End Sub
#超軽量チェックボックス
これしか思いつきませんでした。
1.文字の上に図形を乗せる。
2.図形をクリックでマクロ起動する。
3.図形の左上隅の属するセルを処理対象とする。
初期設定 赤:100 黄:200 を設定
図形クリックでマクロを起動します。
説明のために、図形に色付け、実際には、塗りつぶし:透明度100%、線:なし
##オプションボタンはラジオボタン風に
セルの書式で、グループ毎に異なる書式を設定します。
Findで書式指定するのは
Application.FindFormat.NumberFormatLocal = fmt
で書式指定して
ActiveSheet.Cells.Find(What:="*", SearchFormat:=True, lookat:=xlWhole)
同じ書式のセルを検索しています
おまけ
target.EntireRow.Find を使うと、同じ行縛りになります。
同じ行で、1つだけ選択であれば、書式すら設定しなくても大丈夫!
'-------------------
' オブジェクトの線の表示/非表示
' 状態を名称の横に表示する 表示:true 非表示:false
' テキストが設定されていると、ラジオボタン動作する
'-------------------
Sub oval_OnOff()
Dim targetObj As Object
Dim targetText As String
Dim shp As Object
Dim foth As Boolean
Dim rng As Range
Set targetObj = ActiveSheet.Shapes.Range(Application.Caller)
targetText = targetObj.TextFrame.Characters.Text
'ラジオボタン動作のため(vbaでは日本語名が取得できない)
'オブジェクト名の右2隣りセルにオブジェクト.Nameを書き込む
Set rng = ActiveSheet.Cells.Find(What:=Application.Caller, LookIn:=xlValues, lookat:=xlWhole)
If Not rng Is Nothing Then rng.Offset(0, 1).Value = targetObj.Name
If targetText = "" Then
'状態反転
targetObj.Line.Visible = Not targetObj.Line.Visible
Else
'テキストが設定されているので、ラジオボタン動作する
If targetObj.Line.Visible = False Then
targetObj.Line.Visible = True '表示
Call ovalOff(targetObj, targetText, 1) '自分以外非表示
Else
If Not (ovalOff(targetObj, targetText, 2)) Then targetObj.Line.Visible = False '非表示 + グループ内1メンバ対応
End If
End If
'クリックされたオブジェクト名の右隣りセルに状態を書き込む
Call oval_OnOff_find(targetObj.Name, targetObj.Line.Visible)
End Sub
'---
' mode:1 同一文字が設定された図形線非表示
' mode:2 同一文字が設定された図形線非表示 ただし、他に線表示がある場合のみ
Private Function ovalOff(ByVal target As Object, targetText As String, mode As String)
Dim shp As Object
ovalOff = False
For Each shp In ActiveSheet.Shapes
If target.Name <> shp.Name Then
If target.TextFrame.Characters.Text = shp.TextFrame.Characters.Text Then
shp.Line.Visible = False
ovalOff = True
'オブジェクト名の右隣りセルに状態を書き込む
Call oval_OnOff_find(shp.Name, False)
End If
End If
Next shp
End Function
'オブジェクト名の右隣りセルに状態を書き込む
Sub oval_OnOff_find(objName As String, status As Boolean)
Dim rng As Range
Set rng = ActiveSheet.Cells.Find(What:=objName, LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlprevius)
If Not rng Is Nothing Then
rng.Offset(0, 1).Value = status
End If
End Sub
'---
' チェックボックス ON:Wingdings ChrW(254)チェック OFF:Wingdings ChrW(111)ロ
' ラジオボタン ON:Wingdings ChrW(165)◎ OFF:Wingdings ChrW(161)〇
' ラジオボタン ON:ChrW(165)◎ OFF:ChrW(161)〇
Private Sub checkOnOff()
Dim target As Range
Dim srng As Range
Dim firstAddress As String
Dim foth As Boolean
'図の左上隅が属するセルを取得
With ActiveSheet.Shapes(Application.Caller)
Set target = Range(.TopLeftCell, .TopLeftCell)
End With
'結合セルは処理対象外
If target.Count > 1 Then Exit Sub
'処理対象文字判定
If Not (target.Value = ChrW(254) Or target.Value = ChrW(111) Or _
target.Value = ChrW(165) Or target.Value = ChrW(161) Or _
target.Value = "○" Or target.Value = "◎") Then
Exit Sub
End If
' チェックボックス ON:ChrW(254) ←→ OFF:ChrW(111)
If target.Value = ChrW(111) Or target.Value = ChrW(254) Then
If target.Value = ChrW(111) Then target.Value = ChrW(254) Else target.Value = ChrW(111)
Exit Sub
End If
' ラジオボタン ON:ChrW(165)◎ → OFF:ChrW(161)〇
' ラジオボタン ON:ChrW(165)◎ ← OFF:ChrW(161)〇
If target.Value = ChrW(161) Or target.Value = ChrW(165) Or target.Value = "○" Or target.Value = "◎" Then
If target.Value = ChrW(161) Or target.Value = "○" Then
'---
' ON:ChrW(165)◎ ← OFF:ChrW(161)〇
If target.Value = ChrW(161) Then target.Value = ChrW(165)
If target.Value = "○" Then target.Value = "◎"
' 上以外の ON:ChrW(165)◎ → OFF:ChrW(161)〇
Call optionButtonOff(Range(target.Address).NumberFormatLocal, target, 1)
Exit Sub
Else
'---
' ON:ChrW(165)◎ → OFF:ChrW(161)〇 但し、グループ内に◎がなければ変更しない
foth = optionButtonOff(Range(target.Address).NumberFormatLocal, target, 2)
'グループで部品が1つ
If Not (foth) Then
If target.Value = ChrW(165) Then target.Value = ChrW(161)
If target.Value = "◎" Then target.Value = "○"
Exit Sub
End If
End If
End If
End Sub
'---
' mode:1 同一書式の他のボタンをOFF:○ChrW(161)にする
' mode:2 同一書式の他のボタンをOFF:○ChrW(161)にする ただし、ほかに◎がある場合のみ
Private Function optionButtonOff(fmt As String, ByVal target As Range, mode As String)
Dim srng As Range
Dim firstrng As Range
Dim firstAddress As String
optionButtonOff = False
Application.FindFormat.Clear
Application.FindFormat.NumberFormatLocal = fmt
'Set srng = target.EntireRow.Find(What:="*", After:=srng, SearchFormat:=True, lookat:=xlWhole) 行限定
Set srng = ActiveSheet.Cells.Find(What:="*", SearchFormat:=True, lookat:=xlWhole)
If Not (srng Is Nothing) Then
firstAddress = srng.Address
Set firstrng = srng
Do
'Set srng = target.EntireRow.Find(What:="*", After:=srng, SearchFormat:=True, lookat:=xlWhole) 行限定
Set srng = ActiveSheet.Cells.Find(What:="*", After:=srng, SearchFormat:=True, lookat:=xlWhole)
If srng Is Nothing Then Exit Do
If Not (srng.Address = target.Address) Then
optionButtonOff = True ' グループ内に複数ある
If srng.Value = ChrW(165) Or srng.Value = "◎" Then
If mode = 1 Then
If srng.Value = ChrW(165) Then srng.Value = ChrW(161)
If srng.Value = "◎" Then srng.Value = "○"
ElseIf mode = 2 Then
If target.Value = ChrW(165) Then target.Value = ChrW(161)
If target.Value = "◎" Then target.Value = "○"
Exit Function
End If
End If
End If
If srng.Address = firstAddress Then Exit Do
Loop
End If
End Function
この方法は、非常に軽いcheckboxです。
10,000個のチェックボックスで、300kbです。
また、ダブルクリック方式であれば100kbです。
ExcelのフォームコントロールやActiveXコントロールでは考えられない軽さです。
文字に〇をつける
タネは、図をクリックで「図の線を表示/非表示」マクロを呼び出します。
表示/非表示の状態を取得できるようにしています。
図の名前を設定した右横のセルに 表示:TRUE 非表示:FALSE を設定します。
マクロはこんな感じです。
Sub oval_OnOff()
ActiveSheet.Shapes.Range(Array(Application.Caller)).Line.Visible = Not ActiveSheet.Shapes.Range(Array(Application.Caller)).Line.Visible
Call oval_OnOff_find(Application.Caller, ActiveSheet.Shapes.Range(Array(Application.Caller)).Line.Visible)
End Sub
Sub oval_OnOff_find(objName As String, status As Boolean)
Dim rng As Range
Set rng = ActiveSheet.Cells.Find(What:=objName, LookIn:=xlValues, lookat:=xlWhole)
If Not rng Is Nothing Then
rng.Offset(0, 1).Value = status
End If
End Sub
物忘れ防止 MSチェックボックスその2.xlsm
https://github.com/sugita0301/douzo