[[20100802122147]]　『フォームとチェックボックスを使いチェックしたも』（ななき）　ページの最後に飛ぶ

『フォームとチェックボックスを使いチェックしたものを表示させたい』（ななき）

エクセルについてあまり詳しくなく、色々探してみたのですが

 自分の作成したいものが見つからなかったので皆様のお力を貸して下さい。

 CheckBox1・・・北海道地域
 CheckBox2・・・東北地域
 CheckBox3・・・関東地域

 上記のようなチェックボックスを作成し
 CheckBox2”東北地域”がチェックされた場合　
 別シートにある（"都道府県一覧表"）の中の東北地区のみを表示させたく、

 また、北海道地域、東北地域のみ選択された場合選択されたもののみを
 表示する方法を教えて頂けると助かります。

 地域以外にも市区町村や駅もあり
 出きるだけチェックボックスを使用したいと考えているのですが
 初めての作成の為、言葉足らずかもしれないのですけど
 宜しくお願い致します。

 別シートのリストがどのような形なのか分からないので抽象的な答えになりますが・・・
 各リストの左列にVLOOKUPの検索用に一列挿入する。各リストの右端に地域のチェックが入っているかを表示するセルを確保する。
 チェックボックスをONにしたら、各地域のリスト右端にTRUEを表示させる。
 リストの左端列に、その行のチェックボックスがONなら、その行までのTRUEの個数を数えて表示。offなら空白。
 表示させるシートに、VLOOKUPで表示させる。。。

 リストがどんな配置になってるか分からないから、セル番地とか式は直接書けないので
 言葉で書くとこんな感じでしょうか・・・

 (フェンリル)

フェンリル様

説明不足にも関わらずご回答ありがとうございます。

都道府県一覧表のシートですが

　 A　　　　　 B　　　　C　　　 D　 E

 1 地方	        都道府県	都道府県2	 北海道 青森県
 2 北海道地方	北海道	北海道	 札幌市
 3 東北地方	青森県	青森	 中央区
 4 関東地方	岩手県	岩手	 北区
 5 中部地方	宮城県	宮城	 東区
 6 近畿地方	秋田県	秋田	 白石区
 7 中国地方 	山形県	山形	 豊平区
 8 四国地方	福島県	福島	 南区
 9 九州地方	茨城県	茨城	 西区
 10沖縄地方	栃木県	栃木	 厚別区
 11	　　　　 群馬県	群馬	 手稲区
 12       	埼玉県	埼玉	 清田区
 13	         千葉県	千葉	 函館市

 上記の形になっており
 もし2の東北地方を選択した場合、B列の青森(B3）～福島(B8）までが別シートに表示されるように
 したいのです。

 また、B列の北海道をチェックボックスで選択した場合D列が全て表示される形を考えてます。

 B列の選択が多い場合列が飛ぶのでどのよな形式で出きるか再度教えて頂けますでしょうか宜しくお願い致します。（ななき）

 実際にチェックボックスのリンクするセルがどこにあるのか分からないので、仮定として書きます。
 また、上記の例で言うところの、青森～福島に東北地方がチェックされたよ！っていうことが
 分かるデータ（フラグ）を入れるセルを作らないと判別が難しいです。

 とりあえず仮として、上記のA列とＢ列の間に2列ほど挿入して、Ｂ列をリンクするセルとした場合です。
 Ｂ列にそれぞれのチェックボックスのリンクするセルを設定すれば、チェックが入るとTRUEと表示されます。
 Ｇ列にフラグを入れるとします。
 Ｇ２セル=B2　Ｇ３～Ｇ８セル＝B3　Ｇ９～Ｇ１３セル=B4　、これで東北地方にチェックを入れると、東北地方の件名の横にTRUEと表示されます。
 Ｃ２セルに　=IF(G2,COUNTIF($G$2:G2,TRUE),"")　下にフィルコピー
 これでＧ列がTRUEの件名の左端（Ｃ列）に上から連番が入ります。

 後は別シートの表示させたいセルに
=IF(ISERROR(VLOOKUP(ROW(A1),Sheet1!C2:G13,2,FALSE)),"",VLOOKUP(ROW(A1),Sheet1!C2:G13,2,FALSE))　下へフィルコピー（表示させる範囲）
 これでチェックが入った項目だけを表示させることができます。

 北海道のチェックでＤ列が表示したいのであれば、Ｄ列の項目をＢ列の上（青森県の上）に表示させて
 北海道地方にチェックが入ったらそれぞれのＧ列にTRUEが表示されるように変更すれば可能です。

 説明が下手なので言葉が伝わり難いかと思いますが、どうでしょうか・・・。
 (フェンリル)

 チェックボックスでは無理がありませんか？
 たとえば県名のチェックボックスは何個配置しておきますか？
 地方をマルチセレクトがありえるのでしたら全ての都道府県分用意しますか？
 それともＶＢＡでその都度チェックボックスを配置するのですか？

 コンボボックスとか、マルチがありえるのでしたらリストボックスを使うなど
 仕様そのものを考えてみたほうが良いと思いますが。

 リストも１行づつのユニークなリストにしておいた方が後々楽だと思います。

 北海道地方　北海道　札幌市
 北海道地方　北海道　中央区
 北海道地方　北海道　北区
 北海道地方　北海道　東区
           （省略）
 東北地方　　青森県　青森市
 東北地方　　青森県　弘前市
 東北地方　　青森県　八戸市
           （省略）
 関東地方　　茨城県　水戸市
 関東地方　　茨城県　日立市
 関東地方　　茨城県　土浦市

 のように。
 （ｍｏｍｏ）

 （ｍｏｍｏ）さんの言われるようにリストの体裁を変えると応用が利きそうですね。

 実は僕も質問者さんの言われているチェックボックスで必要な項目だけ表示させると言うことを
 自分の仕事で使ったことがあったので、それを例に上記案を出しました。
 確かにチェックボックスを多数配置するのは大変だったので、ここの過去ログにあったVBAで
 チェックボックスを作成して使いました。

 データの数によりますが、質問者さんの場合はチェックボックスは９個しか必要ないと判断したので
 大丈夫だと思ったんですが・・・。

 チェックボックスの数がもっと多数になる場合は、僕の案だと難しいと思います。
 (フェンリル)

 >また、B列の北海道をチェックボックスで選択した場合D列が全て表示される形を考えてます。
 との事なので、最初に地方のチェックボックスで選択した後に表示される
 県名もチェックボックスで選択するのだと判断しました。

 この場合、地方を複数選択すると大幅に県名が増えますね。
 そうじゃなくても地方によって都道府県の数は違うのでチェックボックスの数は増減します。

 という事で、最低でもVBAが必要ですし割りと面倒かな？と思いました。
 （ｍｏｍｏ）

 県名もチェックボックスで選択するとなると大変ですね・・・そうなると関数での対応よりもVBAの方が良さそうですね。VBAになると僕はお手上げかなぁ・・・

 >この場合、地方を複数選択すると大幅に県名が増えますね。
 >そうじゃなくても地方によって都道府県の数は違うのでチェックボックスの数は増減します。
 確かに地方を複数選択すると、大幅に県名は増えますけど、各地方ごとの都道府県数が違っても
 上記案だとチェックボックスは増えない予定です。・・・・と思ったんですが勘違いしてたらすみません。
 (フェンリル)

フェンリル様、ｍｏｍｏ様

 ご回答ありがとうございます。
 フェンリル様、私の説明不足ですので本当にすみません。
 VBAでないと厳しい感じですよね･･･

 チェックボックスは　地域の9個と都道府県の47個を考えておりまして
　計56個なので。

 ちなみにVBAを作成って難しいのでしょうか？
 調べ方が悪いのかチェックしたもののみを表示するVBAが見つからずで
 可能であればその辺り判る方がいらっしゃったら教えて頂けますでしょうか

 すみませんが宜しくお願い致します。（ななき）

 >チェックボックスは　地域の9個と都道府県の47個を考えておりまして
 これが前提条件として許容されるのでしたら可能です。

 でも、リストが現在のままだとかなり面倒です。
 （ＶＢＡでは前述のようにデータベースのようなリストの方が扱いやすい）

 というか、それでもチェックボックスですと面倒ですね・・・
 フォームではなくてコントロールツールボックスのチェックボックスなら・・・

 （ｍｏｍｏ）

ｍｏｍｏ様

 ご回答ありがとうございます。
 コントロールツールボックスですか

 こちらもVBAにての形になりますか

 無知ですみません(ななき）

 一応、フォームのチェックボックスでサンプルコードを作ってみました。
 新規ブックで試してください。

 リストは作り変えていただいてSheet2に

 　　A列　　　　B列　　C列
 1 北海道地方　北海道　札幌市
 2 北海道地方　北海道　中央区
 3 北海道地方　北海道　北区
 4 北海道地方　北海道　東区
            （省略）
 ･ 東北地方　　青森県　青森市
 ･ 東北地方　　青森県　弘前市
 ･ 東北地方　　青森県　八戸市
            （省略）
 ･ 関東地方　　茨城県　水戸市
 ･ 関東地方　　茨城県　日立市
 ･ 関東地方　　茨城県　土浦市

 のようなリストでSheet2のA1からのリストにします。

 次にAlt+F11でVBEを起動して、メニューの挿入→標準モジュールで
 出てきた白い画面に以下のコードを貼り付けます。

 '＃＃＃＃＃＃＃＃＃＃＃＃＃＃　ここからコード　＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃

  Option Explicit

  Sub Auto_Open()
  Dim tbl As Variant, myList As Variant
  Dim i As Long
  With Worksheets("Sheet1")
    .Range("C2").CurrentRegion.ClearContents
    .CheckBoxes.Delete
    .Activate
  End With
  tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(tbl)
      If Not .Exists(tbl(i, 1)) Then
        .Add tbl(i, 1), ""
      End If
    Next i
    myList = .keys
  End With
  For i = 2 To 10
    With Worksheets("Sheet1").Range("B" & i)
      With Worksheets("Sheet1").CheckBoxes.Add(.Left, .Top, .Width, .Height)
        .ShapeRange.Fill.Solid
        .ShapeRange.Fill.ForeColor.SchemeColor = 65
        .Caption = myList(i - 2)
        .OnAction = "ChangeCheck1"
      End With
    End With
  Next i
  End Sub

  Sub ChangeCheck1()
  Dim myCheck As CheckBox
  Dim tbl As Variant, myList As Variant
  Dim mySelect As String
  Dim i As Long
  Worksheets("Sheet1").Range("C2").CurrentRegion.ClearContents
  For Each myCheck In Worksheets("Sheet1").CheckBoxes
    If myCheck.Caption Like "*地方" Then
      If myCheck.Value = 1 Then
        mySelect = mySelect & vbTab & myCheck.Caption
      End If
    Else
      myCheck.Delete
    End If
  Next myCheck
  tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(tbl)
      If mySelect Like "*" & tbl(i, 1) & "*" Then
        If Not .Exists(tbl(i, 1) & vbTab & tbl(i, 2)) Then
          .Add tbl(i, 1) & vbTab & tbl(i, 2), ""
        End If
      End If
    Next i
    myList = .keys
    For i = 1 To .Count
      With Worksheets("Sheet1").Range("C" & i + 1)
        .Value = Replace(myList(i - 1), vbTab, "")
        .ShrinkToFit = True
        With Worksheets("Sheet1").CheckBoxes.Add(.Left, .Top, .Width, .Height)
          .ShapeRange.Fill.Solid
          .ShapeRange.Fill.ForeColor.SchemeColor = 65
          .Caption = Split(myList(i - 1), vbTab)(1)
          .OnAction = "ChangeCheck2"
        End With
      End With
    Next i
  End With
  End Sub

  Sub ChangeCheck2()
  Dim myCheck As CheckBox
  Dim tbl As Variant, myList As Variant
  Dim mySelect As String
  Dim i As Long
  For Each myCheck In Worksheets("Sheet1").CheckBoxes
    If Not myCheck.Caption Like "*地方" Then
      If myCheck.Value = 1 Then
        mySelect = mySelect & vbTab & myCheck.TopLeftCell.Value
      End If
    End If
  Next myCheck
  tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(tbl)
      If mySelect Like "*" & tbl(i, 1) & tbl(i, 2) & "*" Then
        If Not .Exists(tbl(i, 3)) Then
          .Add tbl(i, 3), ""
        End If
      End If
    Next i
    myList = .keys
  End With
  With Worksheets("Sheet1")
    .Range(.Range("D2"), .Range("D2").End(xlDown)).ClearContents
    If UBound(myList) > 0 Then
      .Range("D2").Resize(UBound(myList) + 1).Value = Application.Transpose(myList)
    End If
  End With
  End Sub

 '＃＃＃＃＃＃＃＃＃＃＃＃＃＃　ここまでコード　＃＃＃＃＃＃＃＃＃＃＃＃＃＃＃

 そしたら一度保存して頂いて、再度開いてみてください。
 チェックボックスが出ているはずですので、それをクリックしていじってみてください。

 （ｍｏｍｏ）一部修正(8:49)

ｍｏｍｏ様

 ありがとうございます。
 希望のものです。VBAが判らないので丸写し状態で
 もしかすると編集にてまた判らない部分が出てくるかもしれませんが、その際はまたご相談させて下さい。

 ｍｏｍｏ様本当にありがとうございます。

 あと、ご相談にのってくれました
 フェンリル様も本当にありがとうございました。

（ななき）

 ｍｏｍｏ様

 なぜか中国地方の表示されなくなってしまうのですが
 どのようにすればよいのでしょうか
　
 本当何度もすみません。（ななき）

 それだけでは原因がわかりません
 中国地方をチェックした時ですか？
 それとも中国地方そのものが表示されませんか？
 Sheet2の中国地方のリストはどうなっていますか？
 （ｍｏｍｏ）

ｍｏｍｏ様

 何度もすみませ。
 最初のAuto_Openじたいでは表示されており
 選択ボタンを押すと消えてしまうのです。
 リストは提示のように修正しております。

 　　A列　　　　B列　　C列
 1 北海道地方　北海道　札幌市
 2 北海道地方　北海道　中央区
 3 北海道地方　北海道　北区
 4 北海道地方　北海道　東区
            （省略）
 ･ 東北地方　　青森県　青森市
 ･ 東北地方　　青森県　弘前市
 ･ 東北地方　　青森県　八戸市
            （省略）
 ･ 中国地方　　徳島県　徳島市
 ･ 中国地方　　香川県　香川市

（ななき）

 選択ボタン？　チェックボックスではなくて？
 仮にボタンだとして何のボタンでしょう？
 で、何が出ていて、何が消えてしまうのですか？
 （ｍｏｍｏ）

ｍｏｍｏ様

 チェックボックスです。説明下手ですみません。
 Auto_Openのマクロを起動すると全地域が出ます。
 ↓
 中国地域をチェックすると中国地域のみAuto_Openから消えてしまいChangeCheck1も表示されません。

 また他の地域（例：北海道地域）を選択してもAuto_Openの中国地域のチェックボックスだけが消えてしまうのですが

 他の地域は全て問題なく表示になります。（ななき）

 Auto_Openから消えるというのはどういう意味でしょう？
 中国地方のチェックボックスそのものが無くなるという事ですか？

 ちなみに気になっているのですが
 「中国地方」ではなくて「中国地域」ですか？
 それならば、コード中の　"*地方"　のところを全て　"*地域"　にしないと動作しません。
 無論、リストも全て○○地域に変更してください。

 重要な言葉なので注意してください。
 また、リスト中のA列に空白や改行、スペースなどがあってもダメです。
 （ｍｏｍｏ）

ｍｏｍｏ様

 また表示を下記間違えてましてすみません。
　"*地方"で問題ありません。

 中国地方のチェックボックスそのものが無くなります。
 >A列に空白や改行、スペースなどがあってもダメです
 こちらも空白・改行・スペースは無く中国地方の下にある四国地方、九州地方は
 問題なく表示されます。（ななき）

 ん～・・・　私のほうではそのような状況が再現できませんので
 なんともお答えのしようが無いのですが

 もう一度新規ブックで試してみるとか・・・

 ちなみに、コードは一切変更していませんよね？
 （ｍｏｍｏ）

ｍｏｍｏ様

 はい変更してません、エクセルの問題かと思い
 他のブックで何回か試したのですがそれでもなぜか中国のみ消えてしまって

（ななき）

 ん～何度やっても再現できません。
 実は見えてないだけで存在するとか・・・かな？

 中国地方が消えた時に以下のテストコードを走らせてみて
 メッセージを確認してみてください。

  Sub test()
  Dim c As CheckBox, buf As String, co As Long
  For Each c In Worksheets("Sheet1").CheckBoxes
    If c.Caption Like "*地方" Then
      buf = buf & vbLf & c.Caption
      co = co + 1
    End If
  Next c
  MsgBox co & "個の地方のチェックボックスがあります。" & vbLf & buf
  End Sub

 （ｍｏｍｏ）

ｍｏｍｏ様

 8個のボックスが存在しますと表示されました。
 やはり中国だけ消えてます。

 (ななき）

 そうですか・・・
 見えないだけならEnabledプロパティやVisibleプロパティの値を疑うか
 DoEventsなどで表示できるかな？と思ったのですが

 すいませんが、再現できないのでお答えのしようがありません。

 私としてはフォームを逐一シートに配置していくのは不具合の元でもありますし
 処理も面倒なのであまり使う方法ではありません。
 最初の回答でも書きましたが、コンボボックスやリストボックスをお勧めします。
 それも、可能ならばユーザーフォームで。

 （ｍｏｍｏ）

ｍｏｍｏ様

 色々とありがとうございました。
 VBAはさっぱり判らないので、フォーム作成はちょっと厳しい感じなのですが
 もう少し勉強してみます。（ななき）

こんばんは

折角のｍｏｍｏさんのコードがもったいないので、

Sub Auto_Open()

    Dim tbl As Variant, myList As Variant
    Dim i As Long
    With Worksheets("Sheet1")
        .Range("C2").CurrentRegion.ClearContents
        .CheckBoxes.Delete
        .Activate
    End With
    tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(tbl)
        If Not .Exists(tbl(i, 1)) Then
            .Add tbl(i, 1), ""
        End If
        Next i
        myList = .keys
    End With
    For i = 2 To UBound(myList) + 2
        With Worksheets("Sheet1").Range("B" & i)
            With Worksheets("Sheet1").CheckBoxes.Add(.Left, .Top, .Width, .Height)
            .ShapeRange.Fill.Solid
            .ShapeRange.Fill.ForeColor.SchemeColor = 65
            .Caption = myList(i - 2)
            .OnAction = "ChangeCheck1"
            End With
        End With
    Next i

End Sub

Sub ChangeCheck1()

    Dim myCheck As CheckBox
    Dim tbl As Variant, myList As Variant
    Dim mySelect As String
    Dim i As Long
    Application.ScreenUpdating = False
    Worksheets("Sheet1").Range("C2").CurrentRegion.ClearContents
    On Error Resume Next
    For Each myCheck In Worksheets("Sheet1").CheckBoxes
        If Not IsError(Application.Match(myCheck.Caption, Worksheets("Sheet2").Columns(1), 0)) Then
            Debug.Print Application.Match(myCheck.Caption, Worksheets("Sheet2").Columns(1), 1)
            If myCheck.Value = 1 Then
                mySelect = mySelect & vbTab & myCheck.Caption
            End If
        Else
            myCheck.Delete
        End If
    Next myCheck
    On Error GoTo 0
    tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(tbl)
            If mySelect Like "*" & tbl(i, 1) & "*" Then
                If Not .Exists(tbl(i, 1) & vbTab & tbl(i, 2)) Then
                    .Add tbl(i, 1) & vbTab & tbl(i, 2), ""
                End If
            End If
        Next i
        myList = .keys
        For i = 1 To .Count
            With Worksheets("Sheet1").Range("C" & i + 1)
                .Value = Replace(myList(i - 1), vbTab, "")
                .ShrinkToFit = True
                With Worksheets("Sheet1").CheckBoxes.Add(.Left, .Top, .Width, .Height)
                    .ShapeRange.Fill.Solid
                    .ShapeRange.Fill.ForeColor.SchemeColor = 65
                    .Caption = Split(myList(i - 1), vbTab)(1)
                    .OnAction = "ChangeCheck2"
                End With
            End With
        Next i
    End With
    Application.ScreenUpdating = True

End Sub

Sub ChangeCheck2()

    Dim myCheck As CheckBox
    Dim tbl As Variant, myList As Variant
    Dim mySelect As String
    Dim i As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    For Each myCheck In Worksheets("Sheet1").CheckBoxes
        If IsError(Application.Match(myCheck.Caption, Worksheets("Sheet2").Columns(1), 0)) Then
            If myCheck.Value = 1 Then
                mySelect = mySelect & vbTab & myCheck.TopLeftCell.Value
            End If
        End If
    Next myCheck
    On Error GoTo 0
    tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(tbl)
            If mySelect Like "*" & tbl(i, 1) & tbl(i, 2) & "*" Then
                If Not .Exists(tbl(i, 3)) Then
                    .Add tbl(i, 3), ""
                End If
            End If
        Next i
        myList = .keys
    With Worksheets("Sheet1")
        .Range(.Range("D2"), .Range("D2").End(xlDown)).ClearContents
    End With
        If .Count > 0 Then
            Worksheets("Sheet1").Range("D2").Resize(UBound(myList) + 1).Value = _
                Application.Transpose(myList)
        End If
    End With
    Application.ScreenUpdating = True

End Sub

これでもう一度試して下さい。

Sheet2 のリストに不備が有るとしか思えないです。

（ウッシ）

コメント返信：

[ 一覧(最新更新順) ]

[[20100802122147]] 『フォームとチェックボックスを使いチェックしたも』（ななき） ページの最後に飛ぶ

[[20100802122147]]　『フォームとチェックボックスを使いチェックしたも』（ななき）　ページの最後に飛ぶ