[[20170221103938]]　『オートフィルタの追加or解除について』（サラダ）　ページの最後に飛ぶ

『オートフィルタの追加or解除について』（サラダ）

 初めまして。私はサラダと言います。
 VBAでトグルボタンでのオートフィルタの制御について質問します。VBA制作依頼ではなく質問です。
 ◎は、言葉だけの羅列では見づらいかなって思って作りました。●も◎も内容は同じです。

 質問１
 そもそもVBAでさらにトグルボタンでオートフィルタに、
 一つの列であとから抽出を追加したり解除したりできますか？

 質問２
 IF文で塊ごと(例えばトマトで始まる内容を一まとめに一つのトグルボタン)で制作か、
 それとも一行ごとに(トグルボタン×１５個で)制作すべきですか？

 「基本情報」
 　セル　　　　　　　：Ｃ行
 　抽出用単語ボタン　：トマト　パセリ　イチゴ　←　トグルボタンを再度押すとその検索語のみ解除

 ●　：　内容
 トマトが選んだ後、何も選ばない場合、　　＝トマトのみ
 トマトを選んだ後、トマトを外した場合、　＝抽出解除
 トマトを選んだ後、パセリを選んだ場合、　＝トマト＆パセリ
 トマト＆パセリ後、パセリを外した場合、　＝トマトのみ
 トマトを選んだ後、イチゴを選んだ場合、　＝トマト＆イチゴ
 トマト＆イチゴ後、イチゴを外した場合、　＝トマトのみ

 パセリが選んだ後、何も選ばない場合、　　＝パセリのみ
 パセリを選んだ後、パセリを外した場合、　＝抽出解除
 パセリ＆トマト後、トマトを外した場合、　＝パセリのみ
 パセリを選んだ後、イチゴを選んだ場合、　＝パセリ＆イチゴ
 パセリ＆イチゴ後、イチゴを外した場合、　＝パセリのみ

 イチゴが選んだ後、何も選ばない場合、　　＝イチゴのみ
 イチゴを選んだ後、イチゴを外した場合、　＝抽出解除
 イチゴ＆トマト後、トマトを外した場合、　＝イチゴのみ
 イチゴ＆パセリ後、パセリを外した場合、　＝イチゴのみ

 ◎　：　Ａ＝トマト　Ｂ＝パセリ　Ｃ＝イチゴ　０＝何も選ばない(または抽出だけ解除)
 Ａ　＋　０　＝　Ａ
 Ａ　－　Ａ　＝　０
 Ａ　＋　Ｂ　＝　Ａ＆Ｂ
 Ａ　－　Ｂ　＝　Ａ
 Ａ　＋　Ｃ　＝　Ａ＆Ｃ
 Ａ　－　Ｃ　＝　Ａ

 Ｂ　＋　０　＝　Ｂ
 Ｂ　－　Ｂ　＝　０
 Ｂ　－　Ａ　＝　Ｂ
 Ｂ　＋　Ｃ　＝　Ｃ＆Ｂ
 Ｂ　－　Ｃ　＝　Ｂ

 Ｃ　＋　０　＝　Ｃ
 Ｃ　－　Ｃ　＝　０
 Ｃ　－　Ａ　＝　Ｃ
 Ｃ　－　Ｂ　＝　Ｃ

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

こんにちは

質問１　可能です。

質問２

トグルボタンの使用が前提なら、トグルボタン×１５個作成（ToggleButton1～15）し、

それぞれのCaptionをトマト、パセリ、イチゴ等にしておきます。

各ToggleButtonをクリックした時のClickイベントで、マクロをCallします。

[例]　Call test

Sub test()

    Dim i   As Long
    Dim j   As Long
    Dim s() As String
    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        If .AutoFilterMode = False Then
            .Range("A6").CurrentRegion.AutoFilter
        ElseIf .FilterMode = True Then
            .ShowAllData
        End If

        For i = 1 To 4
            With .OLEObjects("ToggleButton" & i).Object
                If .Value = True Then
                    j = j + 1
                    ReDim Preserve s(1 To j)
                    s(j) = .Caption
                End If
            End With
        Next

        With Worksheets("Sheet1")
            If j = 0 Then
                If .FilterMode = True Then .ShowAllData
            Else
                .Range("A6").CurrentRegion.AutoFilter _
                    Field:=1, Criteria1:=s, _
                    Operator:=xlFilterValues
            End If
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Sheet1のA6からのデータにフィルタを掛けるとします。（A6は項目名）

一旦全データを表示してから再度フィルタリングします。

但し、何故トグルボタンなのか？　疑問です。

（ウッシ） 2017/02/21(火) 11:54

トグルボタンのようにオブジェクトを配置して使う場合、項目が増えた際に、自分でデザインしてボタンを増やし、文字を直す手間がかかりますよね。

別案で、とこかのセル範囲に、対象文字列の一覧を作成しておき、例えば右クリックすると色が付き、再度右クリックだと消えるようにしてはいかがでしょう？これなら、C列丸ごとコピーした後、重複の削除機能で、あっというまに表を一新できますよ。

また、項目選択と実行ボタンで処理を分けるというのも良いのではないかと思います。
（???） 2017/02/21(火) 13:15

 ウッシさん、ありがとうございます！
 なんでトグルボタンかというと、今どのような条件でフィルタがかかっているのかが
 一目でわかるようにするためです。押されている状態ならそれが今現在の抽出条件ですし、
 押されていなければ抽出されていないとわかるからです。
 いちいちほかの空きセルにフィルタの状態を転機させるのもVBA書くの大変ですし、
 という意味からトグルにしました。

 質問１で、できると知り良かったです☆
 ただ、質問２で、１５個全部それぞれの条件用のトグルが必要になるんですね、、、。と
 少し愕然としました。

 とらいえず光は見えたので頑張ります！
 かいとうありがとうございました！
（サラダ） 2017/02/21(火) 13:17

 ???さん(というお名前でいいのでしょうか？文字化けしてるのでしょうか？？？)、
 ありがとうございました。
 ただ、ごめんなさい、ちょっと意味が理解できなくて、
 ふぉるたーかけている状態でさらにほかのセルに何か表記するのでしょうか？
 う～ん、、、想像できない状態です^^;
 でも、ありがとうございました！
（サラダ） 2017/02/21(火) 13:20

禁止用語とか化けている訳では無く、ここでは???と伏せ字で名乗っている（名乗っていない？）のですよ。

データのない行とか列ってありますよね？　というか、そういう部分にボタンを置こうとしているはず。そのあたりのセル範囲を、トグルボタンの代わりにすると、16個目とか追加になっても簡単、という話です。ボタンを押した／押してない状態を、セルの色が付いている／付いていないに置き換えるだけ。
（???） 2017/02/21(火) 13:31

 ？？？さんありがとうございます！
 お名前の件、了解しました！

 ところで、質問の件なのですが
 A6からD6の間に題名が下記のようにあります。
 ほんとはD6以降もいろいろ数値がありますが、D6以降は空白セルがあるので
 省きます。

 鮮度番号　お名前　冷蔵庫番号　偉大さ番号　←項目名は適当です＞＜
 でも間に空きはありません。
 この鮮度番号～横一列にオートフィルタがされています、

 そしてA7から、今はD165まで情報が入っています。空白セルは生まれません。
 そして最初に書いてあったトマトなどは冷蔵庫番号なのです。

 トマトを選んだあと、やっぱりパセリも一緒に見たい、
 よし！トマトとパセリを抽出だ！
 トマトボタンをポチっとなパセリボタンもポチっとな(それぞれのトグルボタンが凹)。
 これでトマトとパセリの抽出状態になります。
 あ、やっぱりトマトいいや。トマトボタンをポチっとな(トグルボタンだとこの時、ボタンが凸)。
 するとこの時、パセリだけの抽出条件だけになるみたいな。。。

 当初はトマト/パセリ/イチゴの３つのトグルボタンで何とかなるよねぇ、、、。
 と思っていたんですがやはりそれぞれの抽出条件ごとに、
 ボタン作成またはセル色作成ですかorz

 やはり道は険しいですね。。。
（サラダ） 2017/02/21(火) 13:48

オートフィルタを使用しているならば、トグルボタンを置かなくとも、オートフィルタのチェックを付けたり外したりするだけですよね？

トグルボタンだと、オートフィルタを設定するマクロを書かないといけないだけで、できる事は同じだと思うのですが、オートフィルタの標準機能を直接使わないのは何故なのでしょうか？
（???） 2017/02/21(火) 13:56

 実はこの質問の前段階で

 トグルボタン１＝トマトを押すと
 他のボタンの抽出条件はクリアし
 M2セルに入っている文字も空白にして、
 さらにほかのトグルボタンをへこんだ状態から戻して
 さらにさらに空白になったM2セルに"トマト"を入力し
 オートフィルタはトマトを抽出せよ！
 というVBAを組んでいました。ネットの中ら探して組み立ててみました。

 なのでこの延長戦で３つのトグルボタンをそれぞれ３つのトグルボタンだけで
 制御できないかなぁって思って質問しました。
 しょうじきVBAの記述は全然思い浮かばなかったので
 まずはできるのかどうか聞いてみたかったんです＞＜

 ちなみに同じプログラムが二つあるのは、二つ書き込まないとなぜか、
 他のトグルボタンが戻らなかったり
 M2に文字が入力またはクリアされなかったり
 トグルを凹から凸にしたとき抽出状態がクリアされなかったり、、
 なんでこの形になりました＞＜

 Private Sub ToggleButton1_Click()

     On Error Resume Next

     Range("M2") = "トマト"
         With ToggleButton1
             If .Value Then
                 Range("D6").AutoFilter Field:=3, Criteria1:="トマト*"
                 ToggleButton2.Value = False
                 ToggleButton3.Value = False
     Range("M2") = "トマト"
             Else
                 .Value = False
                 ActiveSheet.ShowAllData
                 Range("M2").ClearContents
                 ActiveSheet.ShowAllData
             End If
         End With

         With ToggleButton1
             If .Value Then
                 Range("D6").AutoFilter Field:=3, Criteria1:="トマト*"
                 ToggleButton2.Value = False
                 ToggleButton3.Value = False
     Range("M2") = "トマト"
             Else
                 .Value = False
                 ActiveSheet.ShowAllData
                 Range("M2").ClearContents
                 ActiveSheet.ShowAllData
             End If
         End With
 End Sub
（サラダ） 2017/02/21(火) 14:06

 あ！前段階のVBAはそれぞれのトグルボタンだけの抽出で、
 現段階のやりたいVBAは、同時に押したときに使える感じです＞＜
 意味が解らなかったらごめんなさい(汗
（サラダ） 2017/02/21(火) 14:17

こんにちは

テストブックで試して下さい。

A6からD6の間に題名
A7から、今はD165まで情報
冷蔵庫番号でフィルタリング
トグルボタンは無し
A4～O4？まで選択肢

としてます。

Sheet1のシートタブを右クリックしコードの表示でイベントモジュールを追加します。

Private Sub Worksheet_Activate()

    Dim r    As Range
    Dim oDic As Object
    Set oDic = CreateObject("Scripting.Dictionary")
    With Range("C7", Range("C" & Rows.Count).End(xlUp))
        For Each r In .Cells
            oDic(r.Value) = True
        Next
    End With
    With Range("A4").Resize(, oDic.Count)
        .Value = oDic.keys
        .Interior.ThemeColor = xlThemeColorAccent3
    End With
    With Me
        If .AutoFilterMode = False Then
            .Range("A6").CurrentRegion.AutoFilter
        ElseIf .FilterMode = True Then
            .ShowAllData
        End If
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

    Dim t As Range
    With Me
        On Error Resume Next
        Set t = .Range("A4").Resize(, WorksheetFunction.CountA(.Rows(4)))
        On Error GoTo 0
        If t Is Nothing Then Exit Sub
        If Target.Count > 1 Then Exit Sub   '一応
        If Intersect(Target, t) Is Nothing Then Exit Sub
        Cancel = True
        If Target.Interior.ThemeColor = xlNone Then
            Target.Interior.ThemeColor = xlThemeColorAccent3
        ElseIf Target.Interior.ThemeColor = xlThemeColorAccent3 Then
            Target.Interior.ThemeColor = xlNone
        End If
        Call test1
    End With
End Sub

標準モジュールに、

Sub test1()

    Dim r   As Range
    Dim t   As Range
    Dim j   As Long
    Dim s() As String
    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        On Error Resume Next
        Set t = .Range("A4").Resize(, WorksheetFunction.CountA(.Rows(4)))
        On Error GoTo 0
        If t Is Nothing Then Exit Sub

        If .AutoFilterMode = False Then
            .Range("A6").CurrentRegion.AutoFilter
        ElseIf .FilterMode = True Then
            .ShowAllData
        End If

        For Each r In t
            If r.Interior.ThemeColor = xlThemeColorAccent3 Then
                j = j + 1
                ReDim Preserve s(1 To j)
                s(j) = r.Value
            End If
        Next

        With Worksheets("Sheet1")
            If j = 0 Then
                .Range("A6").CurrentRegion.AutoFilter _
                    Field:=1, Criteria1:="s"
            Else
                .Range("A6").CurrentRegion.AutoFilter _
                    Field:=1, Criteria1:=s, _
                    Operator:=xlFilterValues
            End If
        End With
    End With
    Application.ScreenUpdating = True
End Sub

でSheet1を一旦別のシートを表示してからアクティブして下さい。

A4～O4のセルを右クリックで切り替えます。

（ウッシ） 2017/02/21(火) 14:35

ども＾＾

オートフィルターで何を抽出するようにしているか、
http://www.becoolusers.com/excel/auto-filter.html
この選択画面（？）を常時表示したいということではないのですか？
トグルボタン3つだけで複雑な操作をさせるのは、
使う人が迷いませんか？

http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_userform03b.html
↑の中段辺りにあるように、リストボックスにチェックボックスを表示させて
ON/OFFしてはいかがでしょう？

（まっつわん） 2017/02/21(火) 14:36

 ウッシさん、ありがとうございます。
 ただA4から右に向かって灰色のセルと、だぁ～～～～～～～～～～っとC7の内容が書き込まれて
 左クリックすると確かに色は変わりますが抽出ができず全部折りたたまれてしいました。。。
 けどこれはトマトとかの名前が３つくらいならいいかもですが
 ２０個以上になるとだ～～～～～～～っと横に長くなりますね(;´･ω･)

 まっつわんさん、ありがとうございます。
 私ははまだ若い部類ですが、会社の方々が結構お年寄りで
 細かいやつを見て押したりするよりも
  「　と　ま　と　」　　「　ぱ　せ　り」　　「　い　ち　ご　」
 と大きいなボタンの置いて、それを押すことにより表がガチャガチャ動いて
 必要な形を見れたほうが喜ばしいらしく。。。

 最初はトマトはトマトだけって言ってたのに、
 今度はトマトと他のも同時に見たいと言われだして、、、
 ほんとこまったもんです。。。
（サラダ） 2017/02/21(火) 14:59

こんにちは

テーマカラーは環境によって違うのでダメですね。

後、一部

冷蔵庫番号でフィルタリング

にし忘れてました。

全体を差し替えて試して下さい。

Private Sub Worksheet_Activate()

    Dim r    As Range
    Dim oDic As Object
    Set oDic = CreateObject("Scripting.Dictionary")
    With Range("C7", Range("C" & Rows.Count).End(xlUp))
        For Each r In .Cells
            oDic(r.Value) = True
        Next
    End With
    With Range("A4").Resize(, oDic.Count)
        .Value = oDic.keys
        .Interior.Color = 10092441
    End With
    With Me
        If .AutoFilterMode = False Then
            .Range("A6").CurrentRegion.AutoFilter
        ElseIf .FilterMode = True Then
            .ShowAllData
        End If
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

    Dim t As Range
    With Me
        On Error Resume Next
        Set t = .Range("A4").Resize(, WorksheetFunction.CountA(.Rows(4)))
        On Error GoTo 0
        If t Is Nothing Then Exit Sub
        If Target.Count > 1 Then Exit Sub   '一応
        If Intersect(Target, t) Is Nothing Then Exit Sub
        Cancel = True
        If Target.Interior.Color = 16777215 Then
            Target.Interior.Color = 10092441
        ElseIf Target.Interior.Color = 10092441 Then
            Target.Interior.Color = 16777215
        End If
        Call test1
    End With
End Sub

Sub test1()

    Dim r   As Range
    Dim t   As Range
    Dim j   As Long
    Dim s() As String
    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        On Error Resume Next
        Set t = .Range("A4").Resize(, WorksheetFunction.CountA(.Rows(4)))
        On Error GoTo 0
        If t Is Nothing Then Exit Sub

        If .AutoFilterMode = False Then
            .Range("A6").CurrentRegion.AutoFilter
        ElseIf .FilterMode = True Then
            .ShowAllData
        End If

        For Each r In t
            If r.Interior.Color = 10092441 Then
                j = j + 1
                ReDim Preserve s(1 To j)
                s(j) = r.Value
            End If
        Next

        With Worksheets("Sheet1")
            If j = 0 Then
                .Range("A6").CurrentRegion.AutoFilter _
                    Field:=3, Criteria1:="s"
            Else
                .Range("A6").CurrentRegion.AutoFilter _
                    Field:=3, Criteria1:=s, _
                    Operator:=xlFilterValues
            End If
        End With
    End With
    Application.ScreenUpdating = True
End Sub

（ウッシ） 2017/02/21(火) 15:10

冷蔵庫番号ってC7からC165までに入っているのですよね？
（ウッシ） 2017/02/21(火) 15:14

冷蔵庫番号の種類が減る場合も想定して
Worksheet_Activate
の
Dim oDic As Object
の下に
Rows(4).Clear
を入れておいて下さい。
（ウッシ） 2017/02/21(火) 15:25

 うっしさん、返信遅くなりました＞＜
 会議で離席してました！

 質問の回答ですが
 冷蔵庫番号は途切れません。

 これから試してみいます！

（サラダ） 2017/02/21(火) 16:17

 ウッシさん、使ってみました！

 このVBAは、C7～C165に記入されている冷蔵庫番号を
 A4から右に向かって、だーーーーーーーーーーーっと抜き出して
 その並んでるセルを左クリックすると色が変わった上に
 クリックされた番号とおんなじ番号がC列から隠される
 という仕様でOKですか？
（サラダ） 2017/02/21(火) 16:35

こんにちは

C7～C165の冷蔵庫番号って、「トグルボタン×１５個」という話なので15種類位ですよね？

A4～O4位までに表示されると思います。

Sheet1をアクティブにした時点ではA4～O4位に背景色が付いていて、全データが表示されます。

右クリックしたセルは背景色無しになって、抽出対象外になります。

初期状態で逆に全データが非表示にして、A4～O4位の背景色無しの方がいいですか？

（ウッシ） 2017/02/21(火) 16:42

 ウッシさん、ありがとうございます！
 使い方が解りました☆
 最高です☆

 ほんとうにありがとうございました♪
（サラダ） 2017/02/21(火) 16:51

コメント返信：

[ 一覧(最新更新順) ]

[[20170221103938]] 『オートフィルタの追加or解除について』（サラダ） ページの最後に飛ぶ

[[20170221103938]]　『オートフィルタの追加or解除について』（サラダ）　ページの最後に飛ぶ