[[20150526093941]]　『VBA　フィルタの条件３つ』（未知の世界）　ページの最後に飛ぶ

『VBA　フィルタの条件３つ』（未知の世界）

先に簡単な表を作りました
　
【フィルタ】シート

  |   A   |    B   |   C   
1 |   部  |   課   |   値
2 |12B	  |  12B55 |   0 
3 |223	  |  22311 |   9 
4 |12B	  |  12B22 |   1 
5 |223	  |  22333 |   8 
6 |12B	  |  12B55 |   5 
7 |12B	  |  12B55 |   4 
8 |12B	  |  12B75 |   6 
9 |12B	  |  12B34 |   4 
10|999	  |  99976 |   -3 
11|12B	  |  12B88 |   2 
12|12B	  |  12B55 |   7 
13|12B	  |  12B00 |   7

【貼付】シート　例１

  |   A  |    B  |  
1 | 0～5 | 6～10 |
2 |  5   |  3    |←12Bから、12B22を除いた結果

【貼付】シート　例２

  |   A  |    B  |  
1 | 0～5 | 6～10 |
2 |  2   |  2    |←12Bから、12B22と12B55を除いた結果

【貼付】シート　例３

  |   A  |    B  |  
1 | 0～5 | 6～10 |
2 |  1   |  2    |←12Bから、12B22と12B55と12B34を除いた結果

上記のようにVBでしたい。
まず、フィルタシートの表から、部全体から除外したい課があります。
もともと1つだけだったので関数で作っていたのが、増えてしまい、新しく除外したい課がある部が1つのみならず
2つや3つ…となりましたので、ＶＢを使用した方が…と思うようになりました。
が、フィルタは条件2つまでしかできず、3つとなるとうまくいかなくて苦戦しています。(>_<)

・部全体から除外したい課を外した検索結果が出ればいいので、やり方として考えているのは
Ａ１．1つ目のインプットボックスで、最初に、検索したい部を入れる

Ａ２．2つ目のインプットボックスで、除外したい1つ目の課を入れる。

Ａ３．3つ目のインプットボックスで、除外したい2つ目の課を入れる。
　　（除外が1つのときはキャンセル）

Ａ４．4つ目のインプットボックスで、除外したい3つ目の課を入れる。
　　（除外が2つのときはキャンセル）

Ａ５．後は、C列を「0～5」と「6～10」のそれぞれの検索結果を、貼付シートに反映

VBのコード
Dim bu As Variant
Dim ka1 As Variant
Dim ka2 As Variant
Dim ka3 As Variant

Sub test()

 Dim firuta As Worksheet
 Dim sh As Worksheet

 Set firuta = Worksheets("フィルタ")
     firuta.AutoFilterMode = False
     firuta.Range("A1").AutoFilter

 Set sh = Worksheets("貼付")

Do

 bu = Application.InputBox("部を入力して下さい" & vbCrLf & _
                    "ただし、半角入力でお願いします。", Type:=2)

    bu = StrConv(bu, vbNarrow)

 If bu = False Then Exit Sub

 If Application.CountIf(firuta.AutoFilter.Range.Columns(1), bu) > 0 Then Exit Do
    MsgBox "該当する部がありません。[" & bu & "]"

 Loop

Do

 ka1 = Application.InputBox("除外する課を入力して下さい。" & vbCrLf & _
                     "ただし、半角入力でお願いします。", Type:=2)

    ka1 = StrConv(ka1, vbNarrow)

 If ka1 = False Then Exit Do

 If Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka1) > 0 Then Exit Do
    MsgBox "該当する課がありません。[" & ka1 & "]"

 Loop

Do

 ka2 = Application.InputBox("2つ目の除外する課を入力して下さい。" & vbCrLf & _
                    "ただし、半角入力でお願いします。" & vbCrLf & _
                    "除外する課がない時は、キャンセルを押してください。", Type:=2)

    ka2 = StrConv(ka2, vbNarrow)

 If ka2 = False Then Exit Do

 If Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka2) > 0 Then Exit Do
    MsgBox "該当する課がありません。[" & ka2 & "]"

Loop

ka3 = Application.InputBox("3つ目の除外する課を入力して下さい。" & vbCrLf & _

                    "ただし、半角入力でお願いします。" & vbCrLf & _
                    "除外する課がない時は、キャンセルを押してください。", Type:=2)

    ka3 = StrConv(ka3, vbNarrow)

 If ka3 = False Then Exit Do

 If Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka3) > 0 Then Exit Do
    MsgBox "該当する課がありません。[" & ka3 & "]"

Loop

 With firuta.AutoFilter.Range
            .AutoFilter Field:=1, Criteria1:=bu
            .AutoFilter Field:=2, Criteria1:="<>*" & ka1 & "*"
    If ka2 <> False Then .AutoFilter Field:=2, Criteria1:="<>*" & ka1 & "*", _
                                               Operator:=xlAnd, _
                                               Criteria2:="<>*" & ka2 & "*"

    If ka3 <> False Then .AutoFilter Field:=2, Criteria1:=Array("<>*" & ka1 & "*", "<>*" & ka2 & "*", "<>*" & ka3 & "*")
                                               Operator:=xlFilterValues

            .AutoFilter Field:=3, _
                        Criteria1:=">=0", _
                        Operator:=xlAnd, _
                        Criteria2:="<=5"

  sh.Range("A2").Value = WorksheetFunction.Subtotal(3, firuta.AutoFilter.Range.Columns("C")) - 1

            .AutoFilter Field:=3, _
                        Criteria1:=">=6", _
                        Operator:=xlAnd, _
                        Criteria2:="<=10"

  sh.Range("B2").Value = WorksheetFunction.Subtotal(3, firuta.AutoFilter.Range.Columns("C")) - 1

 End With

End Sub

３つだと、arrayを使うといいとみたので使ってみたのですが、構文エラーになります。
…含まないだとダメなのでしょうか？

やり方は、この方法にこだわっていないのですが、今まで除外していた課が将来的に
含まれるようになることもあるかもしれないので、この方法を考えました。

いつもお聞きしてしまい申し訳ないのですが、調べても分からず、教えて下さい。
よろしくお願い致します。

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 残念ながら、xlFilterValues　は、抽出対象文字列を複数与えるのはできますが、否定文字列の指定はできませんねぇ。

 ちょっとコードを書いてみますが、オートフィルターにはこだわりませんよね？

（β） 2015/05/26(火) 09:53

＞抽出対象文字列を複数与えるのはできますが、否定文字列の指定はできません

やっぱり、そうなんですね…。

はい、オートフィルタにはこだわっていません。

（未知の世界） 2015/05/26(火) 09:57

 取り急ぎ書いたのでバグあればご容赦。（しばらくしたら２日間ほど外出するので、バグ対応は当分できないかも）

 本件、フィルターオプション（フィルター詳細設定）が適した処理方式だと思いますが、とりあえず（無理やり）オートフィルターで。

 なお、不要課の指定は、１回で行うようにしています。（12B22,12B55 といったように）

 Sub Sample()
 'オートフィルター
    Dim bu As Variant
    Dim ans As Variant
    Dim vntSec As Variant
    Dim ka As Variant
    Dim firuta As Worksheet
    Dim sh As Worksheet
    Dim secNG As Boolean
    Dim sec As Variant

    Set firuta = Worksheets("フィルタ")
    Set sh = Worksheets("貼付")
    firuta.AutoFilterMode = False
    firuta.Range("A1").AutoFilter

    Do
        bu = Application.InputBox("部を入力して下さい" & vbCrLf & _
                          "ただし、半角入力でお願いします。", Type:=2)
        If bu = False Then Exit Sub
        bu = StrConv(bu, vbNarrow)
        If Application.CountIf(firuta.AutoFilter.Range.Columns(1), bu) > 0 Then Exit Do
        MsgBox "該当する部がありません。[" & bu & "]"
    Loop

    Do
        ans = Application.InputBox("除外する課を入力して下さい。" & vbCrLf & _
                        "複数あれば aaa,bbb,ccc と , で区切って入力してください" & vbCrLf & _
                        "ただし、半角入力でお願いします。" & vbCrLf & _
                        "除外する課がない時は、キャンセルを押してください。", Type:=2)
        If ans = False Then Exit Do

        ans = StrConv(ans, vbNarrow)
        vntSec = Split(ans, ",")
        secNG = False
        For Each ka In vntSec
            If Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka) = 0 Then
                MsgBox "該当する課がありません。[" & ka & "]"
                secNG = True
                Exit For
            End If
        Next

        If Not secNG Then Exit Do
    Loop

    With firuta.AutoFilter.Range
        .AutoFilter field:=1, Criteria1:=bu
        If Not ans = False Then
            sec = WorksheetFunction.Transpose(.Columns(2))
            For Each ka In vntSec
                sec = Filter(sec, ka, False)
            Next
            .AutoFilter field:=2, Criteria1:=sec, Operator:=xlFilterValues
        End If

        sh.UsedRange.ClearContents
        .Copy sh.Range("A1")

    End With

 End Sub

（β） 2015/05/26(火) 10:33

 フィルターオプション案もアップしておきます

 Sub Sample2()
 'フィルターオプション
    Dim bu As Variant
    Dim ans As Variant
    Dim vntSec As Variant
    Dim ka As Variant
    Dim firuta As Worksheet
    Dim sh As Worksheet
    Dim secNG As Boolean
    Dim sec As Variant
    Dim listR As Range
    Dim j As Long

    Set firuta = Worksheets("フィルタ")
    Set sh = Worksheets("貼付")
    Set listR = firuta.Range("A1").CurrentRegion

    Do
        bu = Application.InputBox("部を入力して下さい" & vbCrLf & _
                          "ただし、半角入力でお願いします。", Type:=2)
        If bu = False Then Exit Sub
        bu = StrConv(bu, vbNarrow)
        If Application.CountIf(listR, bu) > 0 Then Exit Do
        MsgBox "該当する部がありません。[" & bu & "]"
    Loop

    Do
        ans = Application.InputBox("除外する課を入力して下さい。" & vbCrLf & _
                        "複数あれば aaa,bbb,ccc と , で区切って入力してください" & vbCrLf & _
                        "ただし、半角入力でお願いします。" & vbCrLf & _
                        "除外する課がない時は、キャンセルを押してください。", Type:=2)
        If ans = False Then Exit Do

        ans = StrConv(ans, vbNarrow)
        vntSec = Split(ans, ",")
        secNG = False
        For Each ka In vntSec
            If Application.CountIf(listR.Columns(2), ka) = 0 Then
                MsgBox "該当する課がありません。[" & ka & "]"
                secNG = True
                Exit For
            End If
        Next

        If Not secNG Then Exit Do
    Loop

    Application.ScreenUpdating = False

    sh.UsedRange.ClearContents
    sh.Range("A1:C1").Value = firuta.Range("A1:C1").Value
    sh.Range("E1").Value = sh.Range("A1").Value
    sh.Range("E2").Value = "'=" & bu
    sh.Range("F1:H1").Value = sh.Range("B1").Value
    If Not ans = False Then
        j = 6
        For Each ka In vntSec
            sh.Cells(2, j).Value = "<>" & ka
            j = j + 1
        Next
    End If

    listR.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=sh.Range("E1:H2"), CopyToRange:=sh.Range("A1:C1"), Unique:=False
    sh.Range("E1").CurrentRegion.Clear

 End Sub

（β） 2015/05/26(火) 10:59

いっぱいありがとうございます！VBに心くじけそうです(^_^;)
本当に、これをササッと書けるのすごいですね(@_@)
別シートに抽出結果がコピーされるんですね～！！

内容が知らないことたくさんあり、調べていたら遅くなりました。
もしかしたら、解釈を間違っている気もしますので、いくつか教えて下さい。

質問

１．vntSec = Split(ans, ",")　←Split関数の返り値(配列)を受け取ったバリアント型変数なので、
　　　　　　　　　　　　　　ここで、それ以降は、配列として操作しているという事？
２．secNG = False　←そのあとにある、ここはtrue(真)false(偽)で、課があるかどうか判定？

３．Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka) = 0
　　の「=0」や「>0」でtrueかfalseを判定しているのでしょうか？

４．またその後の文の
　　secNG = True　←これは、課があれば、for文をぬける？
　　Exit For

５．If Not ans = False Then

            sec = WorksheetFunction.Transpose(.Columns(2))
            For Each ka In vntSec
                sec = Filter(sec, ka, False)
            Next
            .AutoFilter field:=2, Criteria1:=sec, Operator:=xlFilterValues
        End If
　５は、とびとびしか分からなくどういう感じの処理を行っているのでしょうか？

いっぱい聞いてしまい、申し訳ないのですが、よろしくお願いします。
もう1つの下の段は、今から外出なので、パソコン見れないのでたぶん明日しか
できないと思うので、明日してみて、中身を調べます。
（未知の世界） 2015/05/26(火) 13:54

謎が1つとけたので、確認のため、コメントアップしました。
（返事を急いでるわけではないので、気にしないでください）

３．Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka) = 0
　　の「=0」や「>0」でtrueかfalseを判定しているのでしょうか？

If Application.CountIf(firuta.AutoFilter.Range.Columns(1), bu) > 0 Then Exit Do

If Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka) = 0 Then

でいろいろ悩んでいたのですが、たぶん、上は、「>0」なので1件でもヒットすれば、
doから抜け出す。

「=0」は、もし、0件ならば、MsgBox "該当する課がありません。[" & ka & "]"
という意味ですよね、たぶん…。

理解力悪くて…すみません。
ここら辺は、やっとなんとなくわかりました。

（未知の世界） 2015/05/27(水) 13:31

 まず、ご覧になればおわかりの通り、コードの上半分以上は基本的に、そちらの
 もともとのコードにあった部の選択と除外課の指定のロジックをそのまま踏襲しています。
 除外課を最大３回入力させるところを、aaa,bbb,ccc といったように１回で行うようにしただけで
 そこでの有無チェックは、そちらのコードでやっておられたものと同じものです。

１．vntSec = Split(ans, ",")　←Split関数の返り値(配列)を受け取ったバリアント型変数なので、

 　　　　　　　　　　　　　　ここで、それ以降は、配列として操作しているという事？

 　　Split関数は、文字列を指定の区切り文字で分割して要素番号が0から始まる１次元配列に収めます。

 　　入力が aaa だけだった場合は 要素数が1つだけの１次元配列で、その中身は aaa。
 　　aaa,bbb だった場合は　要素数が2つの1次元配列で、最初の要素が aaa、2番目の要素が bbb。
 　　aaa,bbb,ccc だった場合は要素数が3つの1次元配列で、最初の要素が aaa、2番目の要素が bbb、3番目の要素が ccc になります。

 ２．secNG = False　←そのあとにある、ここはtrue(真)false(偽)で、課があるかどうか判定？

 　　除外課が１つなり、２つなり３つなり入力されたとして、それぞれがリストにあるかどうかをループさせてチェックしています。
 　　１つでもリストになければ、そこでエラーメッセージを出してループを抜けます。
 　　すべてがＯＫの時も（もちろん）ループを抜けます。
 　　ループを抜けたときに、エラーがあってループを抜けたのか、すべてＯＫでループを抜けたのか、その判断をする必要があります。
 　　なので、エラーの場合は、そこで secNG = True にしています。
 　　こうして、ループを抜けたときに、SecNG が True なのか False なのかで、それを判断していますので、最初に False にしています。

 ３．Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka) = 0 の「=0」や「>0」でtrueかfalseを判定しているのでしょうか？

 　 これは、元々のそちらのコードで

    If Application.CountIf(firuta.AutoFilter.Range.Columns(2), ka1) > 0 Then Exit Do

    といったコードがありましたよね。それと同じことをしています。ですから、

   「=0」は、もし、0件ならば、MsgBox "該当する課がありません。[" & ka & "]" という意味ですよね、たぶん…。

 　 はい。その通りですね。

 ４．またその後の文の 
　　 secNG = True　←これは、課があれば、for文をぬける？ 
 　　Exit For

     ２．で説明した通りです。課が【なければ】ループを抜けます。

 ５．If Not ans = False Then

            sec = WorksheetFunction.Transpose(.Columns(2))
            For Each ka In vntSec
                sec = Filter(sec, ka, False)
            Next
            .AutoFilter field:=2, Criteria1:=sec, Operator:=xlFilterValues
        End If

 　　除外課がない場合は、課の選択でキャンセルをしますよね。（もともとのコードがそうしていたように）
 　　ということは、この場合、課の絞り込みは不要ですから、フィルタリングをスキップします。

 　　一方、ans が False でない場合は、vntSec に除外課が１つ、あるいは２つ、あるいは３つ格納されていますね。
 　　で、ここが【無理やり】と書いたところですけど、sec という、２列目のすべての値が入った１次元配列に対して
 　　Filter(sec, 指定の除外課, False)　とやりますと、「指定の除外課以外」の配列になります。
 　　いいかえれば、配列から指定の除外課が【削除】されます。これをループで、まわしてやることで、sec は最終的には
 　　【必要な課】だけの配列になります。（同じ課がたくさん登場するので無駄なんですが、まぁ目をつぶって）
 　　こうして、【必要な課】が配列としておさまっている sec を xlFilterValues として抜き出しているわけです。

（β） 2015/05/27(水) 23:58

いつも、たくさん質問してしまいすみません。
説明がわかりやすくて助かります。

このコード、ほかのにも応用できてすごく重宝します！
（いろいろ試している最中ですが、バグは出ていないです）

忙しい中、お返事ありがとうございました。<m(__)m>

（未知の世界） 2015/05/28(木) 14:36

コメント返信：

[ 一覧(最新更新順) ]

[[20150526093941]] 『VBA フィルタの条件３つ』（未知の世界） ページの最後に飛ぶ

[[20150526093941]]　『VBA　フィルタの条件３つ』（未知の世界）　ページの最後に飛ぶ