Excel VBA 逆引き集 | 手動フィルタを自動適用

Excel VBA
スポンサーリンク

手動フィルタを自動適用

「人がかけた絞り込みを、そのまま別シートや次の更新後に再適用したい」——そんな場面に効くテンプレをまとめました。手動フィルタの状態を読み取り、保存・復元・他範囲へ適用まで、初心者でも使える形で解説します。

目的別の使い分け

  • 今かけている手動フィルタをそのまま使う: AutoFilterの状態を読み取り、そのまま抽出・別シートへコピー
  • 条件を保存して後で再適用: 現在のフィルタ条件をシート（設定用セル）へ書き出し、復元
  • 別表へ同じ条件を同期: 元表のフィルタ状態を別表に適用（列対応が取れる前提）
  • 配列で高速に再適用: 可視セルを配列化→再読込後に同じ条件を適用して最小コストで抽出

基本：手動フィルタ状態を読み取って抽出コピー

Sub CopyCurrentFilterToSheet()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    If Not rg.Parent.AutoFilterMode Then
        MsgBox "フィルタが設定されていません": Exit Sub
    End If

    '表示されている行だけコピー
    On Error Resume Next
    rg.SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
    On Error GoTo 0
End Sub
VB
  • ポイント:
    • 現在の見た目をそのままコピーする最短手。手動フィルタの条件には触らないので壊れにくい。
    • 抽出前の確認: AutoFilterModeでフィルタ有無をチェック。

状態の保存：手動フィルタの条件を取得して記録

Sub SaveFilterState()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    If rg.AutoFilter Is Nothing Then
        MsgBox "フィルタ未設定": Exit Sub
    End If

    Dim f As AutoFilter, i As Long, row As Long: row = 2
    Set f = rg.AutoFilter

    '保存先（設定）シートに条件を書き出す：列番号 / Operator / Criteria1 / Criteria2 / VisibleDropDown
    With Worksheets("設定")
        .Range("A1:E1").Value = Array("Field", "Operator", "Criteria1", "Criteria2", "VisibleDropDown")
        For i = 1 To f.Filters.Count
            If f.Filters(i).On Then
                .Cells(row, 1).Value = i
                .Cells(row, 2).Value = f.Filters(i).Operator
                .Cells(row, 3).Value = JoinCriteria(f.Filters(i).Criteria1)
                .Cells(row, 4).Value = JoinCriteria(f.Filters(i).Criteria2)
                .Cells(row, 5).Value = f.Filters(i).VisibleDropDown
                row = row + 1
            End If
        Next i
    End With
End Sub

'Criteria（文字列/配列）を文字列化（OR選択時は配列になるため結合）
Private Function JoinCriteria(ByVal c As Variant) As String
    If IsEmpty(c) Then
        JoinCriteria = ""
    ElseIf IsArray(c) Then
        JoinCriteria = Join(c, "|") '区切りは「|」
    Else
        JoinCriteria = CStr(c)
    End If
End Function
VB
  • ポイント:
    • OperatorとCriteriaを保持すれば、後で同じ条件を再適用できる。
    • OR条件は配列になることがあるため、文字列化して保存。

状態の復元：保存した条件を再適用

Sub RestoreFilterState()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    '一度フィルタをクリア（表示はそのまま残し、再設定で上書き）
    If rg.Parent.AutoFilterMode Then rg.AutoFilter

    Dim wsSet As Worksheet: Set wsSet = Worksheets("設定")
    Dim last As Long: last = wsSet.Cells(wsSet.Rows.Count, "A").End(xlUp).Row
    Dim r As Long

    For r = 2 To last
        Dim field As Long, op As Long, c1 As Variant, c2 As Variant
        field = wsSet.Cells(r, 1).Value
        op = wsSet.Cells(r, 2).Value
        c1 = SplitCriteria(wsSet.Cells(r, 3).Value)
        c2 = SplitCriteria(wsSet.Cells(r, 4).Value)

        If IsArray(c1) Then
            rg.AutoFilter Field:=field, Criteria1:=c1, Operator:=xlFilterValues
        ElseIf op = xlAnd Or op = xlOr Then
            rg.AutoFilter Field:=field, Operator:=op, Criteria1:=c1, Criteria2:=c2
        Else
            rg.AutoFilter Field:=field, Criteria1:=c1
        End If
    Next r
End Sub

'保存時の「|」結合を元の配列/値へ戻す
Private Function SplitCriteria(ByVal s As String) As Variant
    If Len(s) = 0 Then
        SplitCriteria = Empty
    ElseIf InStr(1, s, "|") > 0 Then
        SplitCriteria = Split(s, "|")
    Else
        SplitCriteria = s
    End If
End Function
VB
  • ポイント:
    • ORの複数選択はxlFilterValuesで配列を渡す。
    • AND/ORの範囲条件（日付や数値）はOperatorとCriteria1/2で復元。

別表へ同じ手動フィルタを適用（列対応が一致する前提）

Sub ApplyCurrentFilterToAnotherTable()
    Dim src As Range: Set src = Worksheets("元表").Range("A1").CurrentRegion
    Dim dst As Range: Set dst = Worksheets("別表").Range("A1").CurrentRegion
    If src.AutoFilter Is Nothing Then
        MsgBox "元表にフィルタがありません": Exit Sub
    End If

    '別表のフィルタを一旦解除
    If dst.Parent.AutoFilterMode Then dst.AutoFilter

    Dim f As AutoFilter: Set f = src.AutoFilter
    Dim i As Long
    For i = 1 To f.Filters.Count
        If f.Filters(i).On Then
            Dim op As Long: op = f.Filters(i).Operator
            Dim c1 As Variant, c2 As Variant
            c1 = f.Filters(i).Criteria1
            c2 = f.Filters(i).Criteria2

            If IsArray(c1) Then
                dst.AutoFilter Field:=i, Criteria1:=c1, Operator:=xlFilterValues
            ElseIf op = xlAnd Or op = xlOr Then
                dst.AutoFilter Field:=i, Criteria1:=c1, Operator:=op, Criteria2:=c2
            Else
                dst.AutoFilter Field:=i, Criteria1:=c1
            End If
        End If
    Next i
End Sub
VB
  • ポイント:
    • 列順・見出しが同じであることが条件。異なる場合は「見出し名→列番号」取得に切り替えると安全。

見出し名で対応付けて、フィルタ条件を別表へマッピング

Sub ApplyFilterByHeaders()
    Dim src As Range: Set src = Worksheets("元表").Range("A1").CurrentRegion
    Dim dst As Range: Set dst = Worksheets("別表").Range("A1").CurrentRegion
    If src.AutoFilter Is Nothing Then
        MsgBox "元表にフィルタがありません": Exit Sub
    End If

    Dim srcHead As Range: Set srcHead = src.Rows(1)
    Dim dstHead As Range: Set dstHead = dst.Rows(1)
    If dst.Parent.AutoFilterMode Then dst.AutoFilter

    Dim f As AutoFilter: Set f = src.AutoFilter
    Dim i As Long
    For i = 1 To f.Filters.Count
        If f.Filters(i).On Then
            Dim headerName As String: headerName = CStr(srcHead.Cells(1, i).Value)
            Dim dstField As Long: dstField = FindHeader(dstHead, headerName)
            If dstField = 0 Then GoTo NextFilter

            Dim op As Long: op = f.Filters(i).Operator
            Dim c1 As Variant, c2 As Variant
            c1 = f.Filters(i).Criteria1
            c2 = f.Filters(i).Criteria2

            If IsArray(c1) Then
                dst.AutoFilter Field:=dstField, Criteria1:=c1, Operator:=xlFilterValues
            ElseIf op = xlAnd Or op = xlOr Then
                dst.AutoFilter Field:=dstField, Criteria1:=c1, Operator:=op, Criteria2:=c2
            Else
                dst.AutoFilter Field:=dstField, Criteria1:=c1
            End If
        End If
NextFilter:
    Next i
End Sub

Private Function FindHeader(ByVal headerRow As Range, ByVal name As String) As Long
    Dim hit As Range
    Set hit = headerRow.Find(What:=name, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindHeader = IIf(hit Is Nothing, 0, hit.Column - headerRow.Column + 1)
End Function
VB
  • ポイント:
    • 見出し名で列対応を取るため、列順が違っても同じ条件を適用できる。

高速化と安全ラップ

Sub Filter_SafeWrapStart()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Sub Filter_SafeWrapEnd()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 大量データでも快適に。エラー時でも必ず復帰するように、On Error GoTo Cleanup で後始末を入れる。

よくある落とし穴と対策

  • ラベル: OR条件（複数選択）の保存がうまくいかない
    • 対策: Criteria1が配列になる。保存時は区切り文字で結合、復元時はSplitしてxlFilterValuesで渡す。
  • ラベル: 日付や数値範囲が文字列扱いになる
    • 対策: 範囲指定はOperator（xlAnd/xlOr）＋Criteria1/2で「>=」「<=」を使う。日付はシリアル比較が安定。
  • ラベル: 別表に同じ列順がない
    • 対策: 見出し名で列をマッピング（Findで列番号取得）。列順前提を捨てる。
  • ラベル: フィルタ解除忘れで再適用が重複
    • 対策: 再適用前にrg.AutoFilterで一旦解除して初期化。
  • ラベル: 空白セルや関数の””が基準外
    • 対策: 空白抽出に難がある場合は事前に値化（.Value = .Value）やTrimで正規化してからフィルタ。

例題で練習

'例1：手動フィルタの表示行を「抽出」へコピー
Sub Example_CopyVisible()
    Call CopyCurrentFilterToSheet
End Sub

'例2：手動フィルタの条件を「設定」へ保存→復元
Sub Example_SaveRestore()
    Call SaveFilterState
    '…データ更新後…
    Call RestoreFilterState
End Sub

'例3：元表の手動フィルタ条件を見出し対応で別表へ適用
Sub Example_ApplyByHeaders()
    Call ApplyFilterByHeaders
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました