0
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 3 years have passed since last update.

Excel checkbox optionbutton 重いチェックボックス対策 超軽量チェックボックス

Last updated at Posted at 2020-05-31

excel超軽量チェックボックス

png20060200.png 動画を見る

##ダブルクリックイベントで文字入れ替え
値の取得は、=if(G2="þ",1,0) で簡単に取れます。"þ"は、数式バーに表示される文字をそのまま式に使う。
png20053111.png

worksheet
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回発生して、元の状態になる。
使えない事はないけど。。。。

worksheet
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 を設定
png20053113.png
png20053114.png
図形クリックでマクロを起動します。
説明のために、図形に色付け、実際には、塗りつぶし:透明度100%、線:なし

##オプションボタンはラジオボタン風に
セルの書式で、グループ毎に異なる書式を設定します。
Findで書式指定するのは
Application.FindFormat.NumberFormatLocal = fmt
 で書式指定して
 ActiveSheet.Cells.Find(What:="*", SearchFormat:=True, lookat:=xlWhole)
 同じ書式のセルを検索しています

おまけ
 target.EntireRow.Find を使うと、同じ行縛りになります。
 同じ行で、1つだけ選択であれば、書式すら設定しなくても大丈夫!

checkonoff
'-------------------
' オブジェクトの線の表示/非表示
' 状態を名称の横に表示する 表示: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 を設定します。
マクロはこんな感じです。

oval_onoff
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

0
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
0
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?