[[20130422231458]]　『ボタンを押して□が☑に』（BARNARD）　ページの最後に飛ぶ

『ボタンを押して□が☑に』（BARNARD）

 どのような形でもかまわないのです。

 四角いボタンが3こ　そのボタンには［1年生］［2年生］［3年生］

 ［1年生］をクリックするとH1：H5の
 ☑　ものさし
 ☑　体操服
 ☑　給食袋
 ☑　絵の具
 □　リコーダー　　　　リコーダー以外が☑になって

 ［2年生］をクリックするとH1：H5の
 ☑　ものさし
 ☑　体操服
 ☑　給食袋
 ☑　絵の具
 ☑　リコーダー　　　全部が☑になって

 ［3年生］をクリックするとH1：H5の
 □　ものさし
 ☑　体操服
 ☑　給食袋
 □　絵の具
 ☑　リコーダー　　ものさし、絵の具以外が☑になるように

 □☑と　ものさし、絵の具などは同じセルです。
 ✓っぽかったらどんな✓でもOKです。
 入力規則のリストなら数式などで可能でしょうか？　
 本当はボタンなどをクリックするのがいいのですけども。
 でもどんなのでもかまいません。
 よろしくお願いします。　2003

 フォームのコントロールのチェックボックスを使うのが一番簡単だと思います。

 VBAの知識があれば、マクロの記録を少し訂正すればできると思います。

 検討してみてください

 ichinose

 別の場所に（別シートでも可）に下のような表を作っておいて、名前を「持ち物表」とし、
		1年生	2年生	3年生
ものさし	☑	☑	□
体操服		☑	☑	☑
給食袋		☑	☑	☑
絵の具		☑	☑	□
リコーダー	□	☑	☑

 G1 に リストで「1年生、2年生、3年生」（数字は半角）を選ぶようにしておいて
 I1：I5 に「ものさし」～「リコーダー」を書いておき
 H1=VLOOKUP(I1,持ち物表,LEFT($G$1,1)+1,FALSE)
 を H2以下にコピー というのはどうでしょうか。

 気になったのですが、ボタンだとどのボタンを押した結果か見て判断できるでしょうか？
 (Mook)

 何をなさりたいのかよく分かりませんが。
	1年生	2年生	3年生
        ものさし  ものさし 体操服
         体操服   体操服   給食袋		
         給食袋   給食袋   リコーダー
          絵の具  絵の具	
                  リコーダー
 のような表をを作っておけばいいのでは。
 この表を見れば １年生に必要な物は	ものさし、体操服、・・・
                ２年生に必用な物は　ものさし、体操服　・・・ 
 一目瞭然、クリックなどいりません。

 現在、2010への移行作業をしています。以前、自作チェックボックス作成コードを
[[20080908154905]]

 投稿しましたが、この質問をみて２０１０で作動させてみたら、作成図形がずれてしまい
 チェックボックスに見えなくなっていました。姑息なことやっていると移行時に不具合が
 発生しやすい？

 この質問のおかげで修正できたので、コードを提示しておきます。
 使用方法は、上のリンク先と同じです。

 標準のモジュールに

 '===========================================================================
 Option Explicit
 Const e2003 = 11
 Sub mk_mycheckbox()
    Dim sp1 As Shape
    Dim sp2 As Shape
    Dim sl As Double, st As Double
    Dim cond As Variant
    Dim rng As Range
    On Error Resume Next
    Set rng = Selection
    cond = get_mkobj_cond
    If TypeName(cond) <> "Boolean" Then
       With rng
          Set sp1 = .Parent.Shapes.AddShape(msoShapeRectangle, .Left, .Top, Val(cond(2)), Val(cond(2)))
          With sp1.Fill
             .Solid
             .ForeColor.RGB = vbWhite
          End With
          With sp1.TextFrame
             .AutoSize = True
             .Characters.Text = ChrW(10003)
             .Characters.Font.Size = Val(cond(2)) - 2
             .Characters.Font.ColorIndex = cond(4)
             .Characters.Font.Bold = cond(5)
             If Val(Application.Version) > e2003 Then
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
             Else
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlTop
                .AutoSize = True
             End If
             .AutoMargins = True
             .AutoSize = False
             .Characters.Text = ""
          End With
          Set sp2 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, sp1.Left + sp1.Width + 7.5, sp1.Top, Val(0), Val(0))
          sp2.Fill.Solid
          sp2.Fill.Visible = False
          sp2.Line.Visible = msoFalse
          With sp2.TextFrame
             .AutoSize = True
             .Characters.Text = cond(1)
             .Characters.Font.Size = Val(cond(2))
             .Characters.Font.ColorIndex = cond(4)
             .Characters.Font.Bold = cond(5)
             .HorizontalAlignment = xlCenter
             .VerticalAlignment = xlCenter
          End With
          sp2.Top = sp1.Top + sp1.Height / 2 - sp2.Height / 2
          With .Parent.Shapes.Range(Array(sp1.Name, sp2.Name)).Group
             .OnAction = "mycheck_Click"
             Application.Range(cond(3)).Name = "L" & Replace(.Name, " ", "")
             Application.Range(cond(3)).Value = False
          End With
       End With
    End If
    On Error GoTo 0
 End Sub
 '===============================================================
 Function get_mkobj_cond() As Variant
    Const sz = 11
    Dim ans As Long
    Dim rng As Range
    Dim cond(1 To 5) As Variant
    get_mkobj_cond = False
    cond(1) = Application.InputBox("チェックボックスのテキストを入力してください")
    If TypeName(cond(1)) <> "Boolean" Then
       cond(2) = Application.InputBox("文字サイズを８～72の範囲で指定してください", , sz)
       If TypeName(cond(2)) <> "Boolean" Then
          If Val(cond(2)) >= 8 And Val(cond(2)) <= 72 Then
             On Error Resume Next
             Set rng = Application.InputBox("リンクセルを選択して下さい", , , , , , , 8)
             If Err.Number = 0 Then
                cond(3) = rng.Address(, , , True)
                cond(4) = Application.InputBox("文字及び、チェックの色をパレット番号で指定して下さい", , "0")
                If IsNumeric(cond(4)) Then
                   ans = MsgBox("太字にしますか?", vbYesNoCancel)
                   If ans <> vbCancel Then
                      If ans = vbYes Then
                         cond(5) = True
                      Else
                         cond(5) = False
                      End If
                      get_mkobj_cond = cond()
                   End If
                End If
             End If
             On Error GoTo 0
          End If
       End If
    End If
    Erase cond()
 End Function
 '===================================================================================
 Sub mycheck_Click()
    Dim ref As String
    Dim gnm As String
    Dim shp As Shape
    Dim ss As Shape
    Dim nm() As Variant
    Dim g0 As Long
    If TypeName(Application.Caller) = "String" Then
       Set shp = ActiveSheet.Shapes(Application.Caller).ParentGroup
       ref = "L" & Replace(shp.Name, " ", "")
       For Each ss In shp.GroupItems
          ReDim Preserve nm(g0)
          nm(g0) = ss.Name
          g0 = g0 + 1
       Next
       gnm = shp.Name
       shp.Ungroup
       With ActiveSheet
          For g0 = LBound(nm()) To UBound(nm())
             With .Shapes(nm(g0))
                If .Type = 1 Then
                   With .TextFrame.Characters
                     If .Text = "" Then
                        .Text = ChrW(10003)
                        Application.Range(ref).Value = True
                     Else
                        .Text = ""
                        Application.Range(ref).Value = False
                     End If
                   End With
                   Exit For
                End If
             End With
          Next
       End With
       With ActiveSheet.Shapes.Range(nm()).Regroup
          .Name = gnm
       End With
    End If
 End Sub

 Excel2002、2010で動作確認です。

 これで作成できる図形が使えるなら、検討してみてください

 ichinose

コメント返信：

[ 一覧(最新更新順) ]

[[20130422231458]] 『ボタンを押して□が☑に』（BARNARD） ページの最後に飛ぶ

[[20130422231458]]　『ボタンを押して□が☑に』（BARNARD）　ページの最後に飛ぶ