一つのセルの中に二個のチェックボックスを作りたい

質問

Excel2003の質問です、宜しくお願いします。

　一つのセルの中で　「□良い　□悪い」という回答にチェックを入れて貰うような
フォームみたいなものを設定したいのですが、どのようにしたら良いのでしょうか。
　Wordなら、ツールバーのフォームから設定できそうなのですが、Excelの一つのセル
の中に二つ以上のチェックボックスの設定の仕方が分かりません。

　また、二個以上のチェックをつけるとセルの色が赤になるとか、何もつけない
（シートを開いた状態）と緑になるとかにしたいのですが、どのようにしたら良いのか、
さっぱり分かりません。
　宜しくお願いします。

回答No.8

Wendy02

私の#6のマクロについて、ご指摘があったようですが、オブジェクトとセルの位置関係は連動し、設定にはある程度、正確さが必要だというだけです。今度は、新たにチェックボックスを取り付ける場合、設定まで自動的に行うマクロを披露します。セルに機械的に納まります。数が数百でも、1秒程度で出来ます。

　*Range("B1:B30") 'チェックボックスの範囲
　*Const EA　'何行おきか？(n -1 )行置き

'//標準モジュール
Private Const EA As Integer = 2 '*
Sub AddFormCheckBoxes()
　'チェックボックスの設定マクロ
　Dim rng As Range
　Dim i As Long, j As Long
　Dim aSh As Worksheet
　If EA = 0 Then Exit Sub
　Set aSh = ActiveSheet
　　Set rng = aSh.Range("B2:B30") '*
　　rng.EntireColumn.ColumnWidth = 16
　　With rng
　　　j = 1
　　　For i = 1 To .Rows.Count Step EA
　　　With .Cells(i, 1)
　　　'左側のチェックボックス
　　　With aSh.CheckBoxes.Add(.Left + 5, .Top + 1, .Width / 3, .Height / 8)
　　　　.Name = "CB" & j
　　　　.Caption = "良い"
　　　　.OnAction = "CheckBoxes_Click"
　　　　j = j + 1
　　　End With
　　　'右側のチェックボックス
　　　With aSh.CheckBoxes.Add(.Left + 50, .Top + 1, .Width / 3, .Height / 8)
　　　　.Name = "CB" & j
　　　　.Caption = "悪い"
　　　　.OnAction = "CheckBoxes_Click"
　　　　j = j + 1
　　　End With
　　　End With
　　　Next i
　　End With
　Set aSh = Nothing
　Set rng = Nothing
End Sub

Private Sub CheckBoxes_Click()
　'CheckBoxのマクロ
　Dim n As String
　Dim myCell As Range
　Dim i As Long, j As Long, k As Long, m As Long
　With ActiveSheet
　　m = .CheckBoxes(1).TopLeftCell.Row
　　n = Application.Caller
　　i = Replace(n, "CB", "", , , 1)
　　If i Mod 2 = 0 Then
　　　j = i - 1
　　　k = j
　　Else
　　　j = i + 1
　　　k = i
　　End If
　　Set myCell = .Cells(Int((k - 1) / 2) * EA + m, 2)
　　If .CheckBoxes("CB" & i).Value = xlOn And _
　　　.CheckBoxes("CB" & j).Value = xlOn Then
　　　myCell.Interior.ColorIndex = 38 '赤
　　ElseIf .CheckBoxes("CB" & i).Value = xlOff And _
　　　.CheckBoxes("CB" & j).Value = xlOff Then '1個
　　　myCell.Interior.ColorIndex = 35 '緑
　　Else
　　　myCell.Interior.ColorIndex = xlNone '色なし
　　End If
　End With
　Set myCell = Nothing
End Sub

'おまけ
Sub ClearCheckBoxes()
'チェックボックスの削除
Dim cb As Object
　Application.ScreenUpdating = False
　For Each cb In ActiveSheet.CheckBoxes
　 cb.TopLeftCell.ClearFormats
　 cb.Delete
　Next cb
　Application.ScreenUpdating = True
End Sub