チェキボ自動作成

Formチェキボ自動作成
シート上で、[名前][タグ][ラベル] の3列を含む範囲を選択して実行（行数は任意）

Option Explicit

'========================
' 一括作成（フォームチェックボックス）
' 使い方：
'   1) シートで [名前][タグ][ラベル] の3列を選択
'   2) BulkCreateFormCheckBoxesFromSelection を実行
'   ※ 各行の「選択範囲の右隣の列」に配置。列を変えたい場合は定数を変更
'========================
Public Sub BulkCreateFormCheckBoxesFromSelection()
    Const TARGET_OFFSET_COLUMNS As Long = 1   ' 右隣=1。2列右なら2に変更
    Dim sel As Range, ws As Worksheet
    Dim r As Long, nRows As Long
    Dim nm As String, tg As String, lb As String
    Dim anchor As Range
    Dim scrUpd As Boolean, evt As Boolean

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲（3列）を選択してください。", vbExclamation
        Exit Sub
    End If

    Set sel = Selection
    Set ws = sel.Worksheet

    If sel.Columns.Count <> 3 Then
        MsgBox "選択範囲は3列（[名前][タグ][ラベル]）で選択してください。", vbExclamation
        Exit Sub
    End If
    If ws.ProtectContents Then
        MsgBox "シートが保護されています。解除してから実行してください。", vbExclamation
        Exit Sub
    End If

    ' 高速化
    scrUpd = Application.ScreenUpdating: Application.ScreenUpdating = False
    evt = Application.EnableEvents: Application.EnableEvents = False

    nRows = sel.Rows.Count
    For r = 1 To nRows
        nm = CStr(sel.Cells(r, 1).Value)
        tg = CStr(sel.Cells(r, 2).Value)
        lb = CStr(sel.Cells(r, 3).Value)

        If Len(Trim$(nm)) > 0 Then
            If Len(Trim$(lb)) = 0 Then lb = nm  ' ラベル未入力なら名前を既定に
            Set anchor = sel.Cells(r, 3).Offset(0, TARGET_OFFSET_COLUMNS)
            CreateFormCheckBoxAt anchor, nm, tg, lb
        End If
    Next r

CleanExit:
    Application.ScreenUpdating = scrUpd
    Application.EnableEvents = evt
    MsgBox "チェックボックスの一括作成が完了しました。", vbInformation
End Sub

'========================
' 個別作成（アンカーセル指定）
'  - TagはShape.AlternativeTextに保存
'========================
Private Function CreateFormCheckBoxAt( _
    ByVal anchorCell As Range, _
    ByVal ctlName As String, _
    ByVal tag As String, _
    ByVal caption As String _
) As Excel.CheckBox
    Dim ws As Worksheet
    Dim cb As Excel.CheckBox
    Dim l As Double, t As Double, w As Double, h As Double
    Dim uniqName As String

    Set ws = anchorCell.Parent

    ' 位置とサイズ（セルに合わせる）
    l = anchorCell.Left
    t = anchorCell.Top
    w = anchorCell.Width
    h = anchorCell.Height * 0.85

    uniqName = MakeUniqueControlName(ws, ctlName)

    Set cb = ws.CheckBoxes.Add(l, t, w, h)
    With cb
        .Name = uniqName
        .Caption = caption
        .Value = xlOff
        .Placement = xlMoveAndSize
        .PrintObject = True
    End With

    ' フォームCBにはTagが無いのでShapeのAltTextに格納
    ws.Shapes(cb.Name).AlternativeText = tag

    Set CreateFormCheckBoxAt = cb
End Function

'========================
' 補助：ユニーク名の採番（フォーム/ActiveX両方を見る）
'========================
Private Function MakeUniqueControlName(ByVal ws As Worksheet, ByVal baseName As String) As String
    Dim nameTry As String, i As Long
    nameTry = baseName: i = 1
    Do While ControlNameExists(ws, nameTry)
        nameTry = baseName & "_" & Format$(i, "000")
        i = i + 1
    Loop
    MakeUniqueControlName = nameTry
End Function

Private Function ControlNameExists(ByVal ws As Worksheet, ByVal nameToFind As String) As Boolean
    Dim ole As OLEObject
    Dim cb As Excel.CheckBox
    For Each cb In ws.CheckBoxes
        If LCase$(cb.Name) = LCase$(nameToFind) Then ControlNameExists = True: Exit Function
    Next
    For Each ole In ws.OLEObjects
        If LCase$(ole.Name) = LCase$(nameToFind) Then ControlNameExists = True: Exit Function
    Next
End Function

'========================
'（任意）タグで一括ON/OFF
'========================
Public Sub SetFormCheckByTag(ByVal tagContains As String, ByVal checked As Boolean)
    Dim ws As Worksheet, cb As Excel.CheckBox
    Set ws = ActiveSheet
    For Each cb In ws.CheckBoxes
        If InStr(1, ws.Shapes(cb.Name).AlternativeText, tagContains, vbTextCompare) > 0 Then
            cb.Value = IIf(checked, xlOn, xlOff)
        End If
    Next cb
End Sub

'========================
'（任意）タグ取得（名前→タグ）
'========================
Public Function GetFormCheckTag(ByVal ctlName As String) As String
    On Error Resume Next
    GetFormCheckTag = ActiveSheet.Shapes(ctlName).AlternativeText
End Function