1. はじめに
ＡＲアドバンストテクノロジ株式会社（ＡＲＩ）の鈴木タクヤです。
以下リンク先の記事を書いてから半年以上過ぎ、私もExcelマクロによる簡単な自動化ツールをVBA1で作成し、業務で使用できるようになりました。
そこで今回は、汎用性が高くExcelを使う人なら全員使えるのではないかと思われる（私見）、「オートフィルター」に関するツールを作成したので、こちらで共有します。是非使ってみてください。
ツール（のコード）は無償配布です。無断で使用・拡散いただいて構いませんが、記事への「いいね」をいただけますと幸いです。
以下、本記事では
2. ツールの概要
3. ツールの導入方法
4. VBAのソースコード
5. 解説記事のリンク
について記載します。
（このツールの詳細な説明に関連して、「Excelフィルタリングツール解説シリーズ」として、不定期で連載する予定です。）
2. ツールの概要
以下で紹介するツールは、Excelの表のフィルタリング条件を設定した後、1ボタンでその設定を適用したり、フィルターを解除して全行を表示したりするものになります。
Excelを使用した業務でありがちな以下の作業が効率化されます。
・定期的に更新される表に毎回決まった条件でフィルターをかける
・表にフィルターをかけて更新し、フィルター解除後に上書き保存
など
フィルター対象のシートに非表示の列がある場合、正常に動作しない場合があります。列の再表示後にツールを実行し直してください。
以下、画面キャプチャは「Microsoft® Excel® for Microsoft 365 MSO (バージョン 2310 ビルド 16.0.16924.20054) 64 ビット」のものです。
①以下のような表のフィルタリングの場合、
②ツールのA1～A5セルに対象のExcelファイルと表見出しの端のセルの情報を入力し、
③「表見出しのコピー」ボタンを押下すると、コピーした表見出しをA7セルから貼り付けます。
④コピーされた見出しの下に抽出条件を入力し「フィルタリング」ボタンを押下すると、
⑤フィルタリングされます！
※ワイルドカードも使用可能で、「*」を入力すると空白セル以外、「=」を入力すると空白セルのみ抽出可能です！！
⑥そして「フィルタのクリア」ボタン押下で表が全行表示されます！
（ファイルの上書き保存の際に便利）
※見出しが複数行の場合にも対応しています。
3. ツールの導入方法
3-1 VBAコードのコピー&ペースト
①ツール用のExcelファイル（以下フィルタリングツール）を新規で作成します。
②「開発」タブの「Visual Basic」（もしくは Alt + F11）を押下します。
※「開発」タブがリボンに存在しない場合は「ファイル」タブ-（「その他...」-）「オプション」で表示する「Excelのオプション」画面で、「リボンのユーザー設定」からリボンに「開発」を追加できます。
③ Visual Basicの画面左側の階層にて①で作成したファイル配下が選択されている状態で、「挿入」タブの「標準モジュール」を押下します。
④作成された「Module1」に、 4. VBAのソースコード に記載のソースコードをコピー＆ペーストします。
本記事をPCから表示した場合は、マウスポインタをコードブロックの上に移動すると右上に表示されるボタン押下で簡単に全行コピーできます。
（「Module1」 に Ctrl + V 等でペースト）
⑤フィルタリングツールを「マクロ有効ブック(*.xlsm)」として（お好きなファイル名で、お好きな場所に）保存します。
3-2 フィルタ対象の情報を入力
①フィルタリングツールに以下の情報を入力します。
- A1セル：フィルタリングしたいブックの保存されているフォルダの絶対パス（対象ファイルの場所）
- A2セル：フィルタリングしたいブックのファイル名
- A3セル：対象シート名
- A4セル：フィルタリングしたい表の見出し左上端のセル番地
- A5セル：フィルタリングしたい表の見出し右下端のセル番地
※A1セルに入力する内容は対象ブックをフォルダ上で右クリック-「プロパティ」の「全般」タブ-「場所」からコピー&ペーストできます。
3-3 マクロ実行用のボタンの配置
①「開発」タブ-「挿入」-「ボタン（フォームコントロール）」を押下します。
②マウスポインタが「＋」になったことを確認し、ボタンを配置したい箇所にドラッグしてボタンを作成します。
フィルタリングツールの7行目以降はマクロの処理で削除されることがあるため、ボタンを配置しないでください！！
③「マクロの登録」画面で「copyHeader」をWクリックします。
④「ボタン1」が作成されるので、ボタンを右クリック-「テキストの編集」からボタンの用途「表見出しのコピー」を入力し、適宜ボタンの幅を調整します。
⑤上記の①～④と同様の手順で「フィルタのクリア」「フィルタリング」「処理中ポインタ解除」のボタンも作成します。対応するマクロ名（上記③マクロの登録画面でWクリックするもの）は以下の通りです。
- 「フィルタのクリア」
⇒「clearFilter」 - 「フィルタリング」
⇒「filter」 - 「処理中ポインタ解除」
⇒「endMacro」
※「exeCommonProc」は他のマクロ処理から間接的に呼ばれるため、対応するボタンは不要です。
以上で導入完了です！おつかれさまでした！！
「表見出しのコピー」を押下してフィルタリングしたい表の見出しが表示されること、抽出条件入力後に「フィルタリング」押下で対象の表がフィルタリングされること等を確認してみてください。
※ツールの使用前に、念のため対象ファイルのバックアップの取得をおすすめします。
簡単なエラーハンドリングはしていますが、マクロの実行時エラーとなった場合には、ポップアップの「終了」ボタンを押下してください。
この場合、マウスポインタが処理中の状態のままとなるので、上記⑤で作成した「処理中ポインタ解除」ボタンを押下してください。
次回からは本ツールのコード解説編です。具体的な処理の流れや、実行時エラーでマウスポインタが復旧しない理由なども記載予定ですので、そちらも「いいね」をいただけますと私が大いに喜びます！！
4. VBAのソースコード
'このツールの設定値を代入する変数の定義
Dim modeNo As Integer 'マクロの起動モード設定用（0:表見出しのコピー, 1:フィルタリング, 2:フィルタのクリア）
Dim settingSheetName As String 'フィルタ条件等を記載する本ツールの設定用シート名
Dim targetBookPath As String 'フィルタ対象のExcelブック格納先（フォルダのパス）
Dim targetBookName As String 'フィルタ対象のExcelブック名
Dim fullPath As String 'フィルタ対象のExcelブックの絶対パス
Dim targetSheetName As String 'フィルタ対象のExcelシート名
Dim startingCell As String '表見出し左上端セル
Dim endCell As String '表見出し右下端セル
Dim settingBook As Workbook 'フィルタリングツール（このブック）
Dim targetBook As Workbook 'フィルタ対象ブック
'■共通処理（複数のマクロから呼ばれる）
Sub exeCommonProc()
'処理高速化のおまじない
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.Cursor = xlWait
End With
'メイン処理開始
settingSheetName = ActiveSheet.Name 'シート名を取得
'変数に設定値を代入
targetBookPath = Sheets(settingSheetName).Range("A1").Value
targetBookName = Sheets(settingSheetName).Range("A2").Value
fullPath = targetBookPath & "\" & targetBookName
targetSheetName = ThisWorkbook.Sheets(settingSheetName).Range("A3").Value
startingCell = Sheets(settingSheetName).Range("A4").Value
endCell = Sheets(settingSheetName).Range("A5").Value
Set settingBook = Workbooks(Application.ThisWorkbook.Name)
'既に対象ブックを開いているか確認する
If isOpened(targetBookName) = True Then
Set targetBook = Workbooks(targetBookName)
Else
'対象ブックの存在確認＆設定
Set targetBook = setFile(fullPath)
End If
'対象シートの存在確認/活性化
Call activateSheet(targetSheetName, targetBook)
'表見出し左上端セル番地のフォーマットチェック
startingCell = checkFormat(startingCell)
'表見出し右下端セル番地のフォーマットチェック
endCell = checkFormat(endCell)
End Sub
'■表見出しのコピー処理
Sub copyHeader()
'起動モードを設定
modeNo = 0
'共通設定処理の呼び出し
Call exeCommonProc
'以下、ツールの設定用シート操作
With settingBook.Sheets(settingSheetName)
'設定用シートを活性化
.Activate
'ざっくり7行目から10行削除
.Rows("7:16").Select
Selection.Delete Shift:=xlUp
'表見出しをツールのA7セルから貼り付ける
targetBook.Sheets(targetSheetName).Range(startingCell, endCell).Copy Destination:=.Range("A7")
'A1セルに戻る
.Range("A1").Select
End With
'マクロ終了処理の呼び出し
Call endMacro
End Sub
'■フィルタリング処理
Sub filter()
'起動モードを設定
modeNo = 1
'フィルタのクリア処理の呼び出し
Call clearFilter
'フィルタリング処理
With settingBook.Sheets(settingSheetName)
'ループ用変数定義
Dim searchValRowNo As Integer '検索値記載開始行番号
searchValRowNo = Range(endCell).Row - Range(startingCell).Row + 8 '初期化（7行目から表見出しをコピーした場合）
Dim i As Integer, j As Integer 'ループカウンタ
Dim searchVal() As String '検索値格納用配列
Dim elementsCount As Integer '検索値格納用配列の要素数
'列移動に関するループ開始（1列目から検索値を確認していく）
For j = 1 To (Range(endCell).Column - Range(startingCell).Column + 1)
'検索値が空文字でなければ、検索値を配列に格納
If .Cells(searchValRowNo, j).Value <> "" Then
elementsCount = .Cells(Rows.Count, j).End(xlUp).Row - searchValRowNo '配列の要素（指定された検索値）の数を計算
ReDim searchVal(elementsCount) '配列の要素数を確定 ※配列のインデックスは0から
For i = 0 To (.Cells(Rows.Count, j).End(xlUp).Row - searchValRowNo) '検索値を上から順に配列に格納するためのループ処理
searchVal(i) = .Cells(searchValRowNo + i, j).Value '※配列のインデックスは0から
Next i
'Withブロックの入れ子に注意！！
With targetBook.Sheets(targetSheetName)
'対象シートにフィルタを適用
.Range(Cells(Range(endCell).Row, Range(startingCell).Column), Cells(Cells(Rows.Count, .Range(startingCell).Column).End(xlUp).Row, Range(endCell).Column)) _
.AutoFilter Field:=j, Criteria1:=Array(searchVal), Operator:=xlFilterValues
End With
End If
Next j
End With
'マクロ終了処理の呼び出し
Call endMacro
End Sub
'■適用済みフィルタのクリア処理
Sub clearFilter()
'起動モードを設定；modeNo=1:フィルタリング でないときは 2:フィルタのクリア に設定する
If modeNo <> 1 Then
modeNo = 2
End If
'共通設定処理の呼び出し
Call exeCommonProc
With targetBook.Sheets(targetSheetName)
'フィルタリング済みの場合は解除
If .AutoFilterMode Then
.Range("A1").AutoFilter
End If
'オートフィルタのドロップダウンを表示
'.Range(Cells(Range(endCell).Row, Range(startingCell).Column), Cells(Cells(Rows.Count, .Range(startingCell).Column).End(xlUp).Row, Range(endCell).Column)).AutoFilter
End With
'起動モードが 2:フィルタのクリア の場合、マクロ終了処理の呼び出し
If modeNo = 2 Then
Call endMacro
End If
End Sub
'■指定のブックを開いているか否かを判定する関数
Function isOpened(ByVal bookName As String) As Boolean
isOpened = False
Dim wb As Workbook
isOpened = False
For Each wb In Workbooks
If wb.Name = bookName Then
isOpened = True
Exit For
End If
Next
Set wb = Nothing
End Function
'■対象ファイル存在確認/設定関数（渡されたfullPathのファイルが存在すればそれを返し、存在しなければエラーメッセージを表示する。）
Function setFile(ByVal fullPath As String) As Workbook
Dim fileChecker As Object
Set fileChecker = CreateObject("Scripting.FileSystemObject")
If fileChecker.FileExists(fullPath) Then
Set setFile = Workbooks.Open(fullPath)
Else
MsgBox "ファイル「" & fullPath & "」が存在しません。"
Call endMacro
End If
Set fileChecker = Nothing
End Function
'■対象シート存在確認/活性化処理（渡されたブック・シート名に該当するシートが存在すれば活性化し、存在しなければエラーメッセージを表示する。）
Sub activateSheet(ByVal sheetName As String, ByVal wb As Workbook)
Dim ws As Worksheet
Dim sheetExists As Boolean '初期値はFalse
For Each ws In wb.Worksheets
If ws.Name = sheetName Then
wb.Sheets(sheetName).Activate
sheetExists = True
Exit For
End If
Next
If Not sheetExists Then
MsgBox "シート「" & sheetName & "」が「" & wb.Name & "」に存在しません。"
Call endMacro
End If
Set ws = Nothing
End Sub
'■セル番地のフォーマットチェック関数
Function checkFormat(ByVal cellReference As String) As String
'全て半角大文字に置換
cellReference = UCase(StrConv(cellReference, vbNarrow))
'文字数を変数に代入
Dim wordCount As Integer
wordCount = Len(cellReference)
'文字列が「英字部分・数字部分」の構成になっていることを確認
If Not cellReference Like "[A-Z]*" Then '先頭が英字であることを確認
Call showFormatErrorMessage(1)
End If
If Not cellReference Like "*[0-9]" Then '末尾が数字であることを確認
Call showFormatErrorMessage(wordCount)
End If
Dim startingPositionOfRowNo As Integer '数字の開始位置が先頭から何文字目かを格納する変数を定義
Dim i As Integer, j As Integer 'ループ処理用変数を定義
'2文字目以降は1文字ずつ英字か数字か確認
For i = 2 To wordCount
If Mid(cellReference, i, 1) Like "[0-9]" Then
startingPositionOfRowNo = i '数字部分（行番号）開始が先頭から何文字目かを保持
Exit For
ElseIf Not Mid(cellReference, i, 1) Like "[A-Z]" Then '数字じゃなくて英字でもなければエラー
Call showFormatErrorMessage(i)
End If
Next i
'数字部分（行番号）の2文字目以降が（存在すれば）全て数字であることを確認
j = startingPositionOfRowNo + 1
Do While j <= wordCount
If Not Mid(cellReference, j, 1) Like "[0-9]" Then '数字以外だったらエラー
Call showFormatErrorMessage(j)
End If
j = j + 1
Loop
'英字部分（列番号）が上限（XFD）以下であることを確認する
Dim columnNo As String
columnNo = Left(cellReference, startingPositionOfRowNo - 1)
'英字部分が4桁以上の場合はエラー
If startingPositionOfRowNo >= 5 Then
Call showFormatErrorMessage(4)
End If
'英字部分が3桁の場合の整合性チェック
If startingPositionOfRowNo = 4 Then
If (Mid(cellReference, 1, 1) Like "[Y-Z]") _
Or (Mid(cellReference, 1, 1) = "X" And Mid(cellReference, 2, 1) Like "[G-Z]") _
Or (Mid(cellReference, 1, 1) = "X" And Mid(cellReference, 2, 1) = "F" And Mid(cellReference, 3, 1) Like "[E-Z]") _
Then
Call showFormatErrorMessage(3)
End If
End If
'数字部分（行番号）が上限（1048576）以下であることを確認する
Dim rowNo As Long
rowNo = CLng(Right(cellReference, wordCount - startingPositionOfRowNo + 1))
If rowNo > 1048576 Then
Call showFormatErrorMessage(wordCount)
End If
checkFormat = cellReference '確認済みの文字列を戻り値に設定
End Function
'■フォーマットエラーメッセージ表示処理
Sub showFormatErrorMessage(ByVal NoFromTheBeginning As Integer)
MsgBox "表見出しの両端を表すセル番地は" & vbCrLf & "列：英字、行：数字（例：A1 など）で指定してください" _
& vbCrLf & " <エラー箇所> " & NoFromTheBeginning & "文字目"
Call endMacro
End Sub
'■マクロ終了処理（処理終了直前にしたいことを実行・エラー落ち時の処理中ポインタ解除）
Sub endMacro()
'処理高速化のおまじない解除
With Application
.Cursor = xlDefault
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End
End Sub
5. 解説記事のリンク
第1回
第2回
第3回
第4回
・
・
・
第5回以降
...Comming Soon!!?
-
VBA：V isual B asic for A pplication の略。Microsoft Office のアプリケーションの機能を拡張するためのプログラミング言語。 ↩