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

10780 ワード
マクロ checkbox Excel 文字 optionbutton Excel テキストリンク

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


動画を見る

ダブルクリックイベントで文字入れ替え

値の取得は、=if(G2="þ",1,0) で簡単に取れます。"þ"は、数式バーに表示される文字をそのまま式に使う。

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には、クリックイベントが無い（簡単には使えない）ので中途半端なものになりました。
一応シングルクリック対応しましたが、矢印キーでセル移動しても動作する。
セル選択状態ではイベントが発生しない。
ダブルクリックすると、イベントが２回発生して、元の状態になる。
使えない事はないけど。。。。

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

超軽量チェックボックス

これしか思いつきませんでした。
１．文字の上に図形を乗せる。
２．図形をクリックでマクロ起動する。
３．図形の左上隅の属するセルを処理対象とする。
初期設定　赤：100 黄：200 を設定


図形クリックでマクロを起動します。
説明のために、図形に色付け、実際には、塗りつぶし:透明度１００%、線：なし

オプションボタンはラジオボタン風に

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

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

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 '非表示 + グループ内１メンバ対応
        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)

            'グループで部品が１つ
            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