オートフィルタがかかっている列を検索する機能の日付け検索のエラーを改修した

地味に便利に仕事の相棒となっている「オートフィルタがかかっている列を検索する」アドインですが、下記のようなエラーが残っていたので対応しました。

日付けで絞り込みしている列があるとエラー
色で絞り込みしている列があるとエラー

www.excellovers.com

コード
色の判定
日付けの判定
まとめ

コード

Function FilterSearch(AllColumnSearch As Boolean, FilterType As String) As Variant
     Dim i As Long
     Dim n As Long
     Dim myVar As Variant
     Dim myObj As Object
     Dim ColumnsCount As Long
     
     Set myObj = Nothing
     If FilterType = "オートフィルター" Then
          Set myObj = ActiveSheet.AutoFilter
          ColumnsCount = myObj.Filters.Count
     Else
          Dim myListObj As ListObject
          For Each myListObj In ActiveSheet.ListObjects
               If myListObj.Name = FilterType Then
                    Set myObj = ActiveSheet.ListObjects(FilterType).AutoFilter
                    ColumnsCount = ActiveSheet.ListObjects(FilterType).ListColumns.Count
               End If
          Next
     End If
          
     If Not myObj Is Nothing Then
          With myObj
               ReDim myVar(ColumnsCount)
               Dim ListValuesArray(1 To 3) As Variant
               For i = 1 To ColumnsCount
                    If AllColumnSearch Or .Filters(i).On Then
                         ListValuesArray(1) = .Range.Cells(i).Value
                         ListValuesArray(2) = .Range.Cells(i).Address(False, False)
                         ListValuesArray(3) = ""
                                                  
                         If .Filters(i).On Then
'改修箇所→
                              On Error Resume Next
                              Dim myFilterCriteria1 As Variant
                              myFilterCriteria1 = "" '初期化。下記でエラーが有った場合に前の値が残ってしまう
                              myFilterCriteria1 = myObj.Filters(i).Criteria1
                              On Error GoTo 0
                              If myObj.Filters(i).Operator = xlFilterCellColor Then
                                   ListValuesArray(3) = "色フィルタ"
                              ElseIf IsEmpty(myFilterCriteria1) Then
                                   ListValuesArray(3) = ""
'→改修箇所
                              ElseIf IsArray(myFilterCriteria1) Then
                                   ListValuesArray(3) = Join(myFilterCriteria1)
                              Else
                                   ListValuesArray(3) = myFilterCriteria1
                              End If
                         End If
                         myVar(n) = ListValuesArray
                         n = n + 1
                    End If
               Next
          End With
     Else
          n = 0
     End If
     
     If n = 0 Then
          myVar = Array()
     Else
          ReDim Preserve myVar(n - 1)
     End If

     FilterSearch = myVar
End Function

色の判定

色の判定はFilterのOperatorプロパティで判定するようにしました。

名前	内容
xland	引数 criteria1 および Criteria2 の論理積
xlBottom10Items	表示される最低値項目 (引数 criteria1 で指定されているアイテムの数)
xlBottom10Percent	表示される最低値項目 (引数 criteria1 で指定される割合)
xlfiltercellcolor	セルの色
xlfilterdynamic	動的フィルター
xlfilterfontcolor	フォントの色
xlfiltericon	フィルターアイコン
xlfiltervalues	フィルターの値
xlor	引数 criteria1 または Criteria2 の論理和
xlTop10Items	表示される最高値項目 (引数 criteria1 で指定されているアイテムの数)
xlTop10Percent	表示される最高値項目 (引数 criteria1 で指定される割合)

Operatorプロパティで指定するXlAutoFilterOperator列挙型の内、xlfiltercellcolorを判定に使用することで色フィルタが掛かっているかを判定することが出来ます。

docs.microsoft.com

日付けの判定

こちらは残念ながら日付けの判定方法を見つけることが出来ませんでした。

しかしアドイン実行時にエラーを発生させたままに出来ませんので、対策を取りました。

On Error Resume Next
Dim myFilterCriteria1 As Variant
myFilterCriteria1 = ""
myFilterCriteria1 = myObj.Filters(i).Criteria1
On Error GoTo 0

日付けで絞り込みを書けている列のCriteria1(抽出条件)は下記のようになぜかエラーが発生しています。

そのため上記のコードでCriteria1を取得しようとした時にエラーが発生します。
そのため変数myFilterCriteria1には何も代入されずEmptyになっています。
変数myFilterCriteria1をIsEmptyで判定することで、絞り込み条件が日付けの場合でもエラーを発生させずに処理を継続させることにしました。