More than 1 year has passed since last update.

ショートカット登録するだけで事務作業が劇的に効率化するVBAフィルタマクロ

Last updated at 2022-12-30Posted at 2022-12-24

４か月ほど前に投稿した複数条件で一気にフィルタリングできるマクロ↓
https://qiita.com/kan3308/items/1abbd3e662625b5c3745

あれからチューンアップしてかなり実用的なレベルになった気がしないでもないので再掲します。

事務作業でよくExcelのフィルタ機能を使ってるけどなんとなく使い勝手にストレスを感じている方、
割と世界が変わるレベルで便利なのでぜひ試してみてください。

Option Explicit

Public Sub clearFilter()

    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData
    End If

End Sub

Public Sub multiFilter()

    Dim targetColNumber As Long
    Dim keywords() As Variant
    Dim filterErrNumber As Long: filterErrNumber = 1004
    
    targetColNumber = Selection.Column - ActiveSheet.UsedRange.Column + 1
    keywords = rangeTo1DArray(Selection)
    
    On Error Resume Next
    ActiveSheet.UsedRange.AutoFilter targetColNumber, keywords, xlFilterValues
    
    If Err.Number = 0 Then
    ElseIf Err.Number = filterErrNumber Then
        MsgBox "データ範囲外のためフィルタに失敗しました。"
    Else
        MsgBox "想定外エラーです。"
    End If
    On Error GoTo 0

End Sub

'Rangeを１次元配列として返す
Public Function rangeTo1DArray(ByVal rng As Range) As Variant

    Dim tmpArray() As Variant
    Dim i As Long: i = 1
    Dim targetCell As Range
    
    For Each targetCell In rng
        ReDim Preserve tmpArray(1 To i)
        If targetCell.Value <> "" Then
            tmpArray(i) = targetCell.Value
        Else
            tmpArray(i) = ""
        End If
        i = i + 1
    Next
    
    rangeTo1DArray = tmpArray

End Function