選択中のセルでオートフィルタ　他趣味プログラミングblog

選択中のセルでオートフィルタ　他

2020年02月04日

今日はオートフィルタ。
みんな大好きオートフィルタ。

パソコンの操作は、マウスよりキーボードで処理したい派なので、
エクセルのオートフィルタを使うときはカーソル動かすのがめんどくさい。

なので、よく利用するオートフィルタ操作をマクロにして、
ショートカットキー登録をすると便利。

一番使う操作は、選択セルの内容でオートフィルタをする。

コマンドはめっちゃ簡単で、こんだけ。
myRange.AutoFilter field:=fColNo, Criteria1:=selection.text

myRangeはオートフィルタのアドレス。
fieldはオートフィルタ範囲で何列目で絞り込むか。
Criteria1は絞り込む内容。

オートフィルタの範囲、絞込みの有無は、以下で取得できる。（Office TANAKAより）
http://officetanaka.net/excel/vba/tips/tips129.htm

オートフィルタ範囲：ActiveSheet.AutoFilter.Range

絞込み有無：ActiveSheet.AutoFilter.Filters(fColNo).On

使ってみて思うこと。
①すでにその列でフィルタ済みだったら解除したい。
②オートフィルタ外の列だったらオートフィルタの範囲を変えたい。
③データがないのにオートフィルタしないで欲しい。
④他の条件での絞り込みもしたい。
　ア　選択したセル以外で絞込み
　イ　選択したセルの内容を含むセルで絞込み
　ウ　クリップボードの内容を含むセルで絞込み
　エ　空白でなく、０でもないセルで絞込み

今回は、上記に対応したソースを掲載します。
絞込み条件は、Criteria1で指定するだけなので、共通モジュールを用意して、
各プロシージャから呼び出す方法にしました。

Sub ▼選択オートフィルタ()

Dim fText1 As String: fText1 = Format(Selection(1).Value, Selection(1).NumberFormatLocal)

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼選択以外でオートフィルタ()

Dim fText1 As String: fText1 = "<>" & Format(Selection(1).Value, Selection(1).NumberFormatLocal)

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼検索オートフィルタ()

Dim fText1 As String: fText1 = "*" & Format(Selection(1).Value, Selection(1).NumberFormatLocal) & "*"

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼クリップボードオートフィルタ()

Dim fText1 As String: fText1 = "*" & GetCB & "*"

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼空白と0以外でオートフィルタ()

Dim fText1 As String: fText1 = "<>"

Dim fText2 As String: fText2 = "<>0"

Call オートフィルタ共通モジュール(fText1, fText2)

End Sub

Private Function GetCB() As String

'クリップボードから文字列を取得

'https://www.ka-net.org/blog/?p=7537

With CreateObject("Forms.TextBox.1")

.MultiLine = True

If .CanPaste = True Then .Paste

GetCB = .Text

End With

End Function

Private Sub オートフィルタ共通モジュール(fText1 As String, Optional fText2 As String = "")

If ActiveSheet.AutoFilter Is Nothing Then '<>""ではなく、Nothing

' MsgBox "オートフィルタを設定してください。"

' Exit Sub

If MsgBox("選択セルでオートフィルタを実行します", vbOKCancel) = vbOK Then

Selection.AutoFilter

Else

Exit Sub

End If

Dim myRange As Range: Set myRange = ActiveSheet.AutoFilter.Range

Dim Flag_nodata As Boolean

If Cells(Rows.Count, Selection.Column).End(xlUp).Row = 1 And Cells(1, Selection.Column) = "" Then

Flag_nodata = True

Else

Flag_nodata = False

End If

Dim RC As Long

If Selection.Column > myRange(myRange.Count).Column Then ' 列が範囲より右なら

If Flag_nodata = True Then Exit Sub

RC = MsgBox("オートフィルタ外のため範囲を拡張します（再設定）", vbOKCancel, "オートフィルタ範囲拡張の有無")

If RC <> vbOK Then Exit Sub 'キャンセルなら拡張せずに終了

myRange.AutoFilter '一旦オートフィルタを解除

Set myRange = myRange.Resize(, Selection.Column - myRange.Column + 1) 'フィルタ列を選択範囲まで右側に拡張

myRange.AutoFilter

ElseIf Selection.Column < myRange.Column Then

If Flag_nodata = True Then Exit Sub

RC = MsgBox("オートフィルタ外のため範囲拡張します（再設定）", vbOKCancel, "オートフィルタ範囲拡張の有無")

If RC <> vbOK Then Exit Sub 'キャンセルなら拡張せずに終了

myRange.AutoFilter '一旦オートフィルタを解除

Set myRange = Cells(myRange.Row, Selection.Column).Resize(myRange.Rows.Count, myRange.Columns.Count + myRange.Column - Selection.Column) 'フィルタ列を選択範囲まで左側に拡張

myRange.AutoFilter

End If

Dim fColNo As Long: fColNo = Selection.Column - myRange.Column + 1 'フィルタ範囲の何番目の列か

'https://www.moug.net/tech/exvba/0030004.html

If ActiveSheet.AutoFilter.Filters(fColNo).On Then '選択中の列が絞り込まれているなら列フィルタ解除

myRange.AutoFilter field:=fColNo

Else

'絞り込まれてないなら

If Cells(Rows.Count, Selection.Column).End(xlUp).Row = 1 And Cells(1, Selection.Column) = "" Then

'MsgBox "列にデータがありません。終了します。"

Exit Sub

Else

'列にデータがあるのでフィルタする

If fText2 = "" Then

myRange.AutoFilter field:=fColNo, Criteria1:=fText1

Else

myRange.AutoFilter field:=fColNo, Criteria1:=fText1, Criteria2:=fText2, Operator:=xlAnd

End If

End Sub

2023/11/5 追記・修正列幅が狭くて＃＃＃＃＃と表示されていてもオートフィルタができるようソースコード内のフィルタ条件を以下の通り変更しました。

2023/11/13 追記内容を修正。標準書式でエラーが出ないよう、列幅が狭くて＃＃＃＃＃と表示されている場合とその他の場合を分けた。

変更前
Selection(1).Text

変更後
if Left(Selection(1).Text ,1) = "#" then
　Format(Selection(1).Value, Selection(1).NumberFormatLocal)
else
　Selection(1).Text
end if

詳細については、以下の記事を参照。
「選択オートフィルタの改良と標準機能について～.textの列幅エラー対策～」