マクロでフィルタ

質問

複数行のフィルタをしたいのですが、普通のオートフィルタではできませんでした。
やろうとしていることは、
　 |　　A　　|　　B　　|
　+------+------+
1 | 　1.1　 | 　aaa　 |
　+------+------+
2 | 　2.1　 | 　bbb 　|
　+------+------+
3 | 　　 　 |　 ccc 　|
　+------+------+

をA列の2.1でフィルタして

　 |　　A　　|　　B　　|
　+------+------+
2 | 　2.1　 | 　bbb 　|
　+------+------+
3 | 　　 　 |　 ccc 　|
　+------+------+

と表示させたいのですがどうやったらできますでしょうか？
VBAについてはあまり知識はないですがご教授ください。
宜しくお願いします。

回答No.10

pauNed · ベストアンサー

質問者さんへ。
少し余計なおせっかいかもしれませんが、例示が少ないと、要件がうまく伝わらない場合があります。

　　　Ａ　　Ｂ
　１　数字　文字
　２　　10　AAA
　３　　　　BBB
　４　　20　AAA
　５　　　　BBB
　６　　　　CCC
　７　　30　AAA
　８　　　　BBB
　９　　40　AAA
１０　　　　CCC

この時Ａ列の空白セルは『上の数字を引き継ぐ』という事で、
２行目３行目のAAA,BBB は数字10のグループ。
同様に４～６行目は20のグループ。
という事ですね。

なので、オートフィルタでＢ列＝CCC を抽出すると、
抽出された、それぞれのCCCが属するグループ単位に抽出し直したいという事なのでしょう。

　　　Ａ　　Ｂ
　１　数字　文字
　４　　20　AAA
　５　　　　BBB
　６　　　　CCC
　９　　40　AAA
１０　　　　CCC

A列だけが抽出条件であったのなら、#2の zap35 さんの方法が簡単でわかり易いと思いました。
今回、マクロで処理する案を提示してしまいましたが、
何か不具合があった時のコードの修正などを考えると、
提示コード内容をしっかり理解された上で使用なさったほうが良いと感じました。
一応、主要部にコメントつけておきます。

Dim s　As Long　 'オートフィルタ範囲の１行目の行番号を格納するための変数
Dim n　As Long　 '可視セルをLoopする時の、行番号格納用
Dim i　As Long　 'Loopカウンタ
Dim j　As Long　 'Loopカウンタ
Dim d　As Double '行高の値を一時格納。これを元に高さを変更し、強制的に表示。
Dim r　As Range　'可視セル範囲格納用
Dim ri As Range　'Loop用Range型変数

With Sheets("Sheet1")
　　'オートフィルタモードでなければ処理しない
　　If Not .AutoFilterMode Then Exit Sub
　　'オートフィルタで抽出操作していなければ処理しない
　　If Not .FilterMode Then Exit Sub
　　'イベント連鎖防止や画面描画停止やその他コード実行時の速度対策
　　Application.EnableEvents = False
　　Application.ScreenUpdating = False
　　Application.Calculation = xlCalculationManual
　　.Parent.Windows(1).View = xlNormalView
　　.DisplayAutomaticPageBreaks = False
　　With .AutoFilter.Range
　　　　'範囲先頭行番号取得
　　　　s = .Cells(1).Row
　　　　'見出し行を除き、１列目の可視セルを変数に格納
　　　　On Error Resume Next
　　　　Set r = .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible)
　　　　On Error GoTo 0
　　End With
　　'抽出データがあれば処理する
　　If Not r Is Nothing Then
　　　　'表示行の高さ取得
　　　　d = r.Cells(1).Height
　　　　'変数に格納した可視セル範囲をLoop
　　　　For Each ri In r
　　　　　　'Loop開始セルの行番号取得
　　　　　　n = ri.Row
　　　　　　'上方向に調査
　　　　　　For i = n To s Step -1
　　　　　　　　'行高調整
　　　　　　　　.Rows(i).RowHeight = d
　　　　　　　　'空白ではないセルがあったらLoopを抜ける
　　　　　　　　With .Cells(i, 1)
　　　　　　　　　　If Len(.Value) > 0 Then Exit For
　　　　　　　　End With
　　　　　　Next i
　　　　　　'下方向に調査
　　　　　　For j = n + 1 To s + .AutoFilter.Range.Rows.Count - 1
　　　　　　　　With .Cells(j, 1)
　　　　　　　　　　If Len(.Value) > 0 Then Exit For
　　　　　　　　End With
　　　　　　　　.Rows(j).RowHeight = d
　　　　　　Next j
　　　　Next ri
　　　　Set r = Nothing
　　End If
　　Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
　　Application.EnableEvents = True
End With

お礼

ご回答ありがとうございます。

上記ソースで期待通りの動きをしてくれました。

>少し余計なおせっかいかもしれませんが、例示が少ないと、要件がうまく伝わらない場合があります。
確かにその通りだったかもしれません。
以後気を付けます。

回答No.9

Wendy02

こんにちは。Wendy02です。

文字列でcccをフィルタをかけたときは
　　A　　 B
1　数字　文字
3　2.1　 bbb
4　　　　ccc
5　　　　ddd
6　3.1　 eee
7　　　　ccc
. . .

もし、こうだとすると、根本的な考え方が違っていますね。
まず、「オートフィルタ」という範疇には入れられません。ロジック（検索式）が、「オートフィルタ」では成り立ちません。

前のイベント（BeforeDoubleClick, Calculate)というものは、削除するか、コメントブロック(先頭に「'」）をつけてください。

必要なところで、ダブルクリックしてください。上が折りたたまれます。
オートフィルタは、あってもなくてもよいですが、ないほうが、軽いような気がします。なお、2行目をクリックしても、折りたたませません。3行目以降からです。

なお、そのデータの範囲以外のところでダブルクリックすると、元に戻ります。

'-------------------------------------------------------

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

Const LIMITROW As Integer = 2　'タイトル行が、1行目にある場合

　Cancel = True
　Application.ScreenUpdating = False
　If Target.Row <= LIMITROW Then Exit Sub
　If Not Intersect(Target, Range("A1").CurrentRegion) Is Nothing Then
　　Range("A1").CurrentRegion.Offset(1).Resize(Target.Row - LIMITROW).Rows.Hidden = True
　Else
　　Range("A1").CurrentRegion.Offset(1).Resize(Target.Row - LIMITROW).Rows.Hidden = _
　　False
　End If
　Application.ScreenUpdating = True

End Sub

'-------------------------------------------------------

お礼

ご回答ありがとうございます。

親身になって回答を頂いたのですが、pauNedさんから頂いた回答の方が私が考えていたものに近かったためそちらを使用させていただきました。

また機会があったら宜しくお願いします。

回答No.8

pauNed

Private Sub Worksheet_Calculate()
　　Dim s As Long
　　Dim n As Long
　　Dim i As Long
　　Dim j As Long
　　Dim d As Double
　　Dim r As Range
　　Dim ri As Range

　　With Sheets("Sheet1")
　　　　If Not .AutoFilterMode Then Exit Sub
　　　　If Not .FilterMode Then Exit Sub
　　　　Application.EnableEvents = False
　　　　Application.ScreenUpdating = False
　　　　Application.Calculation = xlCalculationManual
　　　　.Parent.Windows(1).View = xlNormalView
　　　　.DisplayAutomaticPageBreaks = False
　　　　With .AutoFilter.Range
　　　　　　s = .Cells(1).Row
　　　　　　On Error Resume Next
　　　　　　Set r = .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible)
　　　　　　On Error GoTo 0
　　　　End With
　　　　If Not r Is Nothing Then
　　　　　　d = r.Cells(1).Height
　　　　　　For Each ri In r
　　　　　　　　n = ri.Row
　　　　　　　　For i = n To s Step -1
　　　　　　　　　　.Rows(i).RowHeight = d
　　　　　　　　　　With .Cells(i, 1)
　　　　　　　　　　　　If Len(.Value) > 0 Then Exit For
　　　　　　　　　　End With
　　　　　　　　Next i
　　　　　　　　For j = n + 1 To s + .AutoFilter.Range.Rows.Count - 1
　　　　　　　　　　With .Cells(j, 1)
　　　　　　　　　　　　If Len(.Value) > 0 Then Exit For
　　　　　　　　　　End With
　　　　　　　　　　.Rows(j).RowHeight = d
　　　　　　　　Next j
　　　　　　Next ri
　　　　　　Set r = Nothing
　　　　End If
　　End With
　　Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
　　Application.EnableEvents = True
End Sub

#効率悪い気が...orz

回答No.7

pauNed

参考。

1)該当のシート名が "Sheet1" だとします。
　　　　　　　　　~~~~~~~~~~
2)新規シートを追加します。そのA1セルに =SUBTOTAL(3,Sheet1!A:A)

3)(2)で追加した新規シートのシートモジュールに以下のコードを置きます。
　~~~~~~~~~~~~~~~~~~~~~~~
（追加した新規シートは後で非表示にしても可）

Private Sub Worksheet_Calculate()
　　Dim s As Long
　　Dim n As Long
　　Dim i As Long
　　Dim j As Long
　　Dim d As Double

　　With Sheets("Sheet1")
　　　　If Not .AutoFilterMode Then Exit Sub
　　　　If Not .FilterMode Then Exit Sub
　　　　Application.EnableEvents = False
　　　　With .AutoFilter.Range
　　　　　　s = .Cells(1).Row
　　　　　　On Error Resume Next
　　　　　　n = .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Cells(1).Row
　　　　　　On Error GoTo 0
　　　　End With
　　　　If n > 1 Then
　　　　　　d = .Cells(n, 1).Height
　　　　　　For i = n To s Step -1
　　　　　　　　.Rows(i).RowHeight = d
　　　　　　　　With .Cells(i, 1)
　　　　　　　　　　If Len(.Value) > 0 Then Exit For
　　　　　　　　End With
　　　　　　Next i
　　　　　　For j = n + 1 To s + .AutoFilter.Range.Rows.Count - 1
　　　　　　　　With .Cells(j, 1)
　　　　　　　　　　If Len(.Value) > 0 Then Exit For
　　　　　　　　End With
　　　　　　　　.Rows(j).RowHeight = d
　　　　　　Next j
　　　　End If
　　End With
　　Application.EnableEvents = True
End Sub

お礼

ありがとうございます。

検証してみたところ、A列のフィルタに関しては期待どうりの結果が返ってきます。
B列もいろいろ試してみたのですが、
　　A　　　B
1　数字　文字
2　1.1　 aaa
3　2.1　 bbb
4　　　　ccc
5　　　　ddd
6　3.1　 eee
7　　　　ccc

をcccでフィルタしたところ

　　A　　　B
1　数字　文字
3　2.1　 bbb
4　　　　ccc
5　　　　ddd
7　　　　ccc

と表示されました。
ここで期待することは
　　A　　　B
1　数字　文字
3　2.1　 bbb
4　　　　ccc
5　　　　ddd
6　3.1　 eee
7　　　　ccc
と表示して欲しいです。

回答No.6

Wendy02

こんにちは。

>これは考えていたイメージに結構近いところがあると思います。
>これがオートフィルタに付与できると申し分ないのですが…。

>B5にddという文字を足して、B列のccでフィルタをかけたら3,4,5列を表示させるっていう感じなのですが。

二段落目は、2.1 を選択すると、という意味と同じですよね。

おっしゃっていることがイメージ的に、はっきりしましたので、作ってみました。（私は、人の言っていることへの反応が遅いので申し訳ないです）まだ、十二分なエラー対策をしておりませんので、不具合があるかもしれません。

今、分かっている範囲ですと、「空白のセル（のみ）」が選択できません。また、Calculate イベント（=何かに対して反応するマクロ）は、意外におかしな反応をするときがありますので、ブック全体で調子をみていただいたほうがよいです。ダメな場合は、別のイベントを考えます。

今ある、オートフィルタで使ってみてください。ただし、A1を左端上の基点としているオートフィルタです。

今の段階では、2列のみです。B列で検索した時には、A列に、その選択フィールドが移動しますので、なるべくA列目で処理をしてください。（たぶん、B列で処理しても問題ないとは思います。）それから、出来ると思っていなかったので、あまり時間が空くと、今回の内容は、分からなくなりそうです。（^^;

シートモジュールです。

'-----------------------------------------------------------

Private Sub Worksheet_Calculate()
'Ver.2726111 01
Dim myCrite As String
Dim myFld As Integer
Dim SearchWd As String
Application.EnableEvents = False
　With Me.AutoFilter
　On Error Resume Next
　myCrite = .Filters(1).Criteria1
　If myCrite <> "" Then myFld = 1
　If Err.Number > 0 Then
　　myCrite = .Filters(2).Criteria1
　　If myCrite <> "" Then myFld = 2
　End If
　On Error GoTo 0
　End With
　On Error GoTo ErrHander
　If myCrite <> "" And myFld = 1 And myCrite <> "=" Then
　Range("A1").CurrentRegion.AutoFilter _
　　 Field:=1, _
　　 Criteria1:=myCrite, _
　　 Operator:=xlOr, _
　　 Criteria2:="="
　ElseIf myCrite <> "" And myFld = 2 And myCrite <> "=" Then
　Me.ShowAllData
　SearchWd = Mid$(myCrite, 2)
　i = WorksheetFunction.Match(SearchWd, Me.AutoFilter.Range.Columns(2), 0)
　myCrite = Me.AutoFilter.Range.Columns(1).Cells(i).Value
　Range("A1").CurrentRegion.AutoFilter _
　　 Field:=1, _
　　 Criteria1:=myCrite, _
　　 Operator:=xlOr, _
　　 Criteria2:="="
　ElseIf myCrite = "=" Then
　　Me.ShowAllData
　End If
ErrHander:
　Application.EnableEvents = True
End Sub

お礼

ありがとうございます。

早速検証してみました。
　　A　　 B
1　数字　文字
2　1.1　 aaa
3　2.1　 bbb
4　　　　ccc
5　　　　ddd
6　3.1　 eee
7　　　　ccc
. . .
. . .
. . .
. . .

としてAセルにて2.1でフィルタしたところ、
　　A　　 B
1　数字　文字
3　2.1　 bbb
4　　　　ccc
5　　　　ddd

と期待通りの結果が表示されました。
しかし、Aセルにて3.1をフィルタしたところ、
　　A　　 B
1　数字　文字
4　　　　ccc
5　　　　ddd
6　3.1　 eee
7　　　　ccc

と表示されてしまいました。

またBセルでcccという文字列を詮索したところ、
　　A　　 B
1　数字　文字
4　　　　ccc
5　　　　ddd
7　　　　ccc
という結果が返されました。

これは、フィルタしたときに4、5列目を必ず範囲に入れるようにしているのでしょうか？

文字列でcccをフィルタをかけたときは
　　A　　 B
1　数字　文字
3　2.1　 bbb
4　　　　ccc
5　　　　ddd
6　3.1　 eee
7　　　　ccc
. . .
. . .
と表示して欲しいです。

回答No.5

pauNed

こんにちは。
>普通のオートフィルタではできませんでした。
という理由は何でしょう？

見出し行が挿入できるなら
Sub sample1()
　　Rows("1").Insert Shift:=xlDown
　　With Range("A1")
　　　　.Resize(, 2).Value = "chk"
　　　　.CurrentRegion.Columns("A:B").AutoFilter Field:=1, _
　　　　　　　　　　　　　　　Criteria1:="=2.1", _
　　　　　　　　　　　　　　　Operator:=xlOr, _
　　　　　　　　　　　　　　　Criteria2:="="
　　End With
　　Rows("1").Hidden = True
End Sub
...こんな感じではダメですか？もちろん一般機能でもできます。

見出し行が挿入できないなら
Sub sample2()
　　With Range("B1", Range("B65536").End(xlUp)).Offset(, 1)
　　　　.Formula = "=OR(A1=2.1,A1="""")"
　　　　.AutoFilter 1, True
　　　　If Not .Cells(1) Then .Rows(1).Hidden = True
　　End With
End Sub
...こんな案も。（ただし作業列使ってしまいますが）

結合セルがらみだったり、条件が『上のセルの値を引き継ぐ』という意味であれば
他の方のレスを参考にされてください。

お礼

ありがとうございます。

>>普通のオートフィルタではできませんでした。
>という理由は何でしょう？
オートフィルタで2.1を表示させたときに3列目のcccが表示されなかったので、コードを書くしかないのかな？と思ったしだいです。

>結合セルがらみだったり、条件が『上のセルの値を引き継ぐ』という
>意味であれば他の方のレスを参考にされてください。
条件的には特にない(表示されればいい)のですが、当初の認識では上のセルの値を引き継ぐ感じでしたのでそちらを優先させたいと思います。

せっかく回答を頂いて申し訳ありませんが、他の方のレスを参考にさせていただきます。

回答No.4

Wendy02

#3 のWendy02です。

別の方法を考えてみました。

フィルタオプションです。（これは、以下のようにマクロに組むことが可能です）
ただし、フィルタオプションの場合に限らず、必ず、タイトル行は入れてください。

　　　A　　　B
1　　数値　文字
2　　1.1　　aa
3　　2.1　　bb
4　　　　　　cc

検索条件

F1 は、何も入れない
F2 に、

=OR(A2=2.1,ISBLANK(A2))

という数式を入れます。数式は、必ず必要です。

本来は、これだけでも、フィルタオプションとしては、十分なのです。

それを、自動で出るようにするために、マクロに換えてしまいます。
これは、シートモジュールに設定します。

シート・マクロの取り付け方：

マクロを実行しようとするワークシートのシートタブ(下部のSheet1,Sheet2 ...)を右クリックすると、「コードの表示(V)」というメニューがありますから、それをクリックしてください。そして、開いた画面に、以下のコードを貼り付けて、Alt + Q で閉じれば設定は完了です。

--------------------------------------------

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'F1 をダブルクリックすると、フィルタが掛かる
'フィルタモードになっているときは、ダブルクリックすると、解除される
Dim myCriter As Range
Cancel = True
If Target.Address <> "$F$1" Then Exit Sub

If Me.FilterMode = True Then Me.ShowAllData: Exit Sub
Set myCriter = Range("F1").CurrentRegion
If WorksheetFunction.CountA(mycriteria) = 0 Then _
　MsgBox "検索値を入れてください", vbInformation: Exit Sub

　Range("A1").CurrentRegion.AdvancedFilter _
　　　　　　Action:=xlFilterInPlace, _
　　　　　　CriteriaRange:=myCriter, _
　　　　　　Unique:=False
Set myCriter = Nothing
End Sub

お礼

ありがとうございます。

これは考えていたイメージに結構近いところがあると思います。
これがオートフィルタに付与できると申し分ないのですが…。

あと、逆のことってできますかね？
B5にddという文字を足して、B列のccでフィルタをかけたら3,4,5列を表示させるっていう感じなのですが。
イメージ的にはccのA列が空白セルで、その上下すべての空白セル＋上の数字(文字)以外を非表示にするんだと思うのですが…。

回答No.3

Wendy02

こんばんは。

もう少し、詳しい話を聞かないと分かりませんね。
それだけの問題でしたら、「2.1」のデータ選択というよりも、「1.1に等しくない」ということではありませんか？

回答No.2

zap35

３行目の空白は上のセルの値（2.1）を引き継ぐということでしょうか？
もしそうであればＣ２に
=IF(A2="",OFFSET(C2,-1,0),A2)
と入力して、そのセルを行数分コピーし、Ｃ列に対してオートフィルタをかける方法が楽だと思います。表示・印刷させたくないなら文字色を白にしておく手もあります。

ただしＣ１にこの式を入れると#REF!エラーとなりますので、Ｃ１だけは値を手入力してください。なおOFFSET関数を利用したのは行削除を行ったときにエラーとならないようにするためです。
それを考慮する必要がなければＣ２の式は
=IF(A2="",C1,A2)
でよいです

回答No.1

mshr1962

一例ですが．．．オートフィルタでは出来ないので表示・非表示させてます。
Sub FILT21()
For Each RG In Range(Range("A2"), Range("A65536").End(xlUp))
Select Case RG
Case 2.1
FX = "ON"
Case Is = ""
'変更なし
Case Else
FX = "OFF"
End Select
If FX = "ON" Then
RG.EntireRow.Hidden = False
Else
RG.EntireRow.Hidden = True
End If
Next RG
End Sub

お礼

ありがとうございます。
なんか書き方が悪かったみたいでご迷惑をおかけしました。

やりたいこととしては、オートフィルタの形式で(ドロップダウンボックス)、空白のセルに上のセルの値を挿入(表示はさせない)をしてフィルタをかけるということです。
ですので、2.1が固定ではないんです…。