ワークシート上のチェックボックスがどのセルにあるかを返すサブルーチン

　もう７年も前になるのか、
　Microsoft Excelで作ったアンケートを集計するためのツールを作った。
　なにしろ集計箇所の指定が楽なのでアンケートのみならず、開発ドキュメントの特定欄（はっきり言って日付）がきちんと辻褄が合っているかのチェックに使ったりして重宝した。

　しかしながら「チェックボックス」には対応してなかったのだな。必要なときはチェックボックスの値を別シートからリンクして、その別シートを集計する、という形で対処していた。

　このたび、直接チェックボックスを扱えるようにしたくなり、作ったサブルーチンがこちら。

　アクティブシートのチェックボックスの一覧をVariant型の二次元配列で返します。
　要素"0"はチェックボックスの名前。
　要素"1"はチェックボックスと最も共有面積が広いセルの行数
　要素"2"は同じく列数
　要素"3"はチェックボックスのON/OFF
　
　どのセルにあると判断するかにはちょっと悩んだ。チェックボックスの左上がかかっているもの、なんてので済めば問題なかったのだが、デフォルトではチェックボックスの高さがセルの高さより大きかったりするんだな。なのでチェックボックスという「図形」と最も広い面積を共有しているセルを選択することとした。

Function チェックボックス一覧取得() As Variant

Dim answer As Variant

Dim cb As CheckBox
Dim Buf As String

Dim 左上端(2) As Single
Dim 左下端(2) As Single
Dim 右上端(2) As Single
Dim 右下端(2) As Single

Dim 左上セル As Range
Dim 右下セル As Range

Dim 上端 As Single
Dim 下端 As Single
Dim 左端 As Single
Dim 右端 As Single

Dim 共有面積 As Single
Dim old_共有面積 As Single
Dim セル行 As Long
Dim セル列 As Long

Dim i As Long, j As Long
Dim ct As Long


    ct = 0
    ReDim answer(0 To 3, 0 To ct)
    
    'チェックボックスをループ
    For Each cb In ActiveSheet.CheckBoxes

        左上端(1) = cb.Left
        左上端(2) = cb.Top
        
        左下端(1) = cb.Left
        左下端(2) = cb.Top + cb.Height
        
        右上端(1) = cb.Left + cb.Width
        右上端(2) = cb.Top
        
        右下端(1) = cb.Left + cb.Width
        右下端(2) = cb.Top + cb.Height + cb.Width
        
        DoEvents
        
        Set 左上セル = cb.TopLeftCell
        Set 右下セル = cb.BottomRightCell
        
        old_共有面積 = 0
        所属セル行 = 0
        所属セル列 = 0
                
        For i = 左上セル.Row To 右下セル.Row
            For j = 左上セル.Column To 右下セル.Column
            
                'セルの作る四角形とチェックボックスの作る四角形の重なり面積を求める
                'まずは重なり部分の左端
                If cb.Left < Cells(i, j).Left Then
                    左端 = cb.Left
                Else
                    左端 = Cells(i, j).Left
                End If
                
                '重なり部分の右端
                If cb.Left + cb.Width > Cells(i, j).Left + Cells(i, j).Width Then
                    右端 = cb.Left + cb.Width
                Else
                    右端 = Cells(i, j).Left + Cells(i, j).Width
                End If
                
                'つまり重なった部分のY軸方向の長さは
                重なりの幅 = cb.Width + Cells(i, j).Width - (右端 - 左端)
                
                '今度は重なり部分の上端
                If cb.Top < Cells(i, j).Top Then
                    上端 = cb.Top
                Else
                    上端 = Cells(i, j).Top
                End If
                
                '続いて下端
                If cb.Top + cb.Height > Cells(i, j).Top + Cells(i, j).Height Then
                    下端 = cb.Top + cb.Height
                Else
                    下端 = Cells(i, j).Top + Cells(i, j).Height
                End If
                
                'ということで重なりの高さは
                重なりの高さ = cb.Height + Cells(i, j).Height - (下端 - 上端)
                
                共有面積 = 重なりの高さ * 重なりの幅
                
                If 共有面積 > old_共有面積 Then
                    old_共有面積 = 共有面積
                    所属セル行 = i
                    所属セル列 = j
                End If
                
                DoEvents
            
            Next j
        Next i
        
        ReDim Preserve answer(0 To 3, 0 To ct)
        
        answer(0, ct) = cb.Name
        answer(1, ct) = 所属セル行
        answer(2, ct) = 所属セル列
        If cb.Value = 1 Then
            answer(3, ct) = "ON"
        Else
            answer(3, ct) = "OFF"
        End If
        
        ct = ct + 1
        
        DoEvents

    Next cb

    チェックボックス一覧取得 = answer
    DoEvents

End Function

このサブルーチンを作ったツール、動画で紹介しています。
https://youtu.be/D4iMNRmpJVo
Microsoft Excelのワークシートで作ったアンケートを集計するツールです。