【ExcelVBA】狭いフィルターを解決する

Japanese

はじめに

Excelのフィルターを使用することはお仕事でよくある。必須ともいえる機能ですが、使用していてフィルターのウィンドウがとても小さいなと感じる場面がありませんか？

かく言う私は、セルの値が長くなれば長くなるほど毎回のようにイライラしながら横にスライドしてフィルターをかけます。

このように長い値になればなるだけ見にくいじゃないですか。

なので今回は既存のフィルターを使用しない方法でフィルターをする方法を紹介します。

フィルターウィンドウ

絞り込み

作成したものについて紹介します。
わかりやすく簡潔な表を作成し、フィルターボタンを押しました。

すると、フィルターウィンドウが表示され入力項目が出現します。
操作方法は、、、

1.見出し範囲の設定
2.フィルターしたい列を指定
3.フィルター内にある値を指定
4.適用

以上が基本操作になります。
解除したい場合は「解除」ボタンを押せば解除されます。

連続でフィルターを適用することも可能です。
一度フィルターしたあと、再度選択し適用することでフィルターできます。

部分検索

チェックボックスにチェックを入れ、検索したいフィルター列を選択。
「開」と入力して適用を押すと画像のように検索することもできます。

使用上の注意

通常のフィルターとこのフィルターウィンドウは別々の動作をします。
なのでフィルターを適用しても見出し範囲は適用されません。

見出し範囲は自身で入力して更新ボタンを押してください。

一度、更新ボタンを押すとExcel内部で値を保管してくれるので、一度ファイルを閉じても問題なく再度開いたときに同じ値がセットされます。

配布について

作成したものを以下のリンクからダウンロードすることができます。
皆さんのお仕事に役に立てたらなと思います。

フィルターウィンドウダウンロード

特に制限はありませんが、良識の範囲でご使用頂けたらと思います。

コード

とはいえ、そんなものをダウンロードしたくない！
という人向けにコードを記載しておきます。

よくわからないという人は以下の記事から読んでみるのもよいかもしれません。

【Excel】マクロ有効ブックでプログラムを使用しよう
はじめに保存する拡張子を変更することでExcelはVBというプログラムを使用できるようになります。使用できるようになることでなにができるのか？Excel関数以上の性能を出すことができる繰り返し作業の自動化外部システムやファイルとの連携と様々...
www.ok-pc.net
2025.09.09

フォーム

Option Explicit

Private mLoading As Boolean
Private Const MAX_CBO_ITEMS As Long = 300

Private Sub txtKeyword_Change()

End Sub

Private Sub UserForm_Initialize()
    Me.StartUpPosition = 1

    cboColumn.Clear
    cboValue.Clear
    txtKeyword.Value = ""
    chkPartial.Value = False

    gFilterRange = LoadSavedFilterRange()
    txtFilterRange.Value = gFilterRange

    RefreshFilterItems
End Sub

Private Sub txtFilterRange_AfterUpdate()
    ' 更新ボタンで反映するため、ここでは何もしない
End Sub

Private Sub cboColumn_Change()
    If mLoading Then Exit Sub
    LoadUniqueValues
End Sub

Private Sub cmdApply_Click()
    Dim ws As Worksheet
    Dim headerRange As Range
    Dim dataRange As Range
    Dim fieldIndex As Long
    Dim criteria As String
    
    On Error GoTo EH
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set ws = ActiveSheet
    Set headerRange = GetHeaderRange(True)
    
    gFilterRange = Trim(txtFilterRange.Value)
    SaveFilterRange gFilterRange
    
    If headerRange Is Nothing Then GoTo ExitPoint
    
    If cboColumn.ListIndex = -1 Then
        MsgBox "フィルターする列を選択してください。", vbExclamation
        GoTo ExitPoint
    End If
    
    fieldIndex = cboColumn.ListIndex + 1
    Set dataRange = GetFilterRangeFromHeader(headerRange)
    
    If Trim(txtKeyword.Value) <> "" Then
        criteria = Trim(txtKeyword.Value)
    ElseIf Trim(cboValue.Value) <> "" Then
        criteria = Trim(cboValue.Value)
    Else
        MsgBox "検索文字を入力するか、候補を選択してください。", vbExclamation
        GoTo ExitPoint
    End If
    
    If chkPartial.Value Then
        dataRange.AutoFilter Field:=fieldIndex, Criteria1:="=*" & EscapeFilterText(criteria) & "*"
    Else
        dataRange.AutoFilter Field:=fieldIndex, Criteria1:="=" & EscapeFilterText(criteria)
    End If
    
    LoadUniqueValues
    
ExitPoint:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

EH:
    MsgBox Err.Description, vbExclamation
    Resume ExitPoint
End Sub

Private Sub cmdClearCurrent_Click()
    Dim headerRange As Range
    Dim dataRange As Range
    Dim fieldIndex As Long
    
    Set headerRange = GetHeaderRange(True)
    If headerRange Is Nothing Then Exit Sub
    
    If cboColumn.ListIndex = -1 Then
        MsgBox "解除する列を選択してください。", vbExclamation
        Exit Sub
    End If
    
    fieldIndex = cboColumn.ListIndex + 1
    Set dataRange = GetFilterRangeFromHeader(headerRange)
    
    dataRange.AutoFilter Field:=fieldIndex
    
    txtKeyword.Value = ""
    cboValue.ListIndex = -1
    
    LoadUniqueValues
    
'    MsgBox "選択列のフィルターを解除しました。", vbInformation
End Sub

' 更新
Private Sub cmdRefresh_Click()
    gFilterRange = Trim(txtFilterRange.Value)
    SaveFilterRange gFilterRange
    RefreshFilterItems
End Sub

' 解除
Private Sub cmdClear_Click()
    Dim ws As Worksheet
    
    Set ws = ActiveSheet
    
    On Error Resume Next
    If ws.FilterMode Then
        ws.ShowAllData
    End If
    On Error GoTo 0
    
    txtKeyword.Value = ""
    cboValue.ListIndex = -1
End Sub

' 閉じる
Private Sub cmdClose_Click()
    Me.Hide
End Sub

Private Sub LoadHeadersFromRange()
    Dim headerRange As Range
    Dim c As Range
    
    cboColumn.Clear
    cboValue.Clear
    
    Set headerRange = GetHeaderRange(False)
    If headerRange Is Nothing Then Exit Sub
    
    For Each c In headerRange.Cells
        cboColumn.AddItem CStr(c.Value)
    Next c
    
    If cboColumn.ListCount > 0 Then
        cboColumn.ListIndex = 0
    End If
End Sub

Private Sub LoadUniqueValues()
    Static isRunning As Boolean
    
    Dim ws As Worksheet
    Dim headerRange As Range
    Dim dataRange As Range
    Dim targetRange As Range
    Dim visibleCells As Range
    Dim area As Range
    Dim cell As Range
    Dim fieldIndex As Long
    Dim v As String
    Dim key As Variant
    Dim dict As Object
    Dim scanCount As Long
    
    Const MAX_SCAN_CELLS As Long = 5000
    
    If isRunning Then Exit Sub
    If mLoading Then Exit Sub
    
    isRunning = True
    On Error GoTo ExitHandler
    
    cboValue.Clear
    
    Set headerRange = GetHeaderRange(False)
    If headerRange Is Nothing Then GoTo ExitHandler
    If cboColumn.ListIndex = -1 Then GoTo ExitHandler
    
    Set ws = ActiveSheet
    Set dataRange = GetFilterRangeFromHeader(headerRange)
    
    fieldIndex = cboColumn.ListIndex + 1
    
    If dataRange.Rows.Count <= 1 Then GoTo ExitHandler
    Set targetRange = dataRange.Columns(fieldIndex).Offset(1, 0).Resize(dataRange.Rows.Count - 1, 1)
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    Set visibleCells = targetRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo ExitHandler
    
    If visibleCells Is Nothing Then GoTo ExitHandler
    
    For Each area In visibleCells.Areas
        For Each cell In area.Cells
            scanCount = scanCount + 1
            If scanCount > MAX_SCAN_CELLS Then GoTo FillCombo
            
            v = Trim$(CStr(cell.Value))
            If v <> "" Then
                If Not dict.Exists(v) Then
                    dict.Add v, v
                    If dict.Count >= MAX_CBO_ITEMS Then GoTo FillCombo
                End If
            End If
        Next cell
    Next area
    
FillCombo:
    For Each key In dict.Keys
        cboValue.AddItem CStr(key)
    Next key

ExitHandler:
    isRunning = False
End Sub

Private Function GetHeaderRange(ByVal showMessage As Boolean) As Range
    Dim ws As Worksheet
    Dim s As String
    Dim rg As Range
    
    Set ws = ActiveSheet
    s = Trim(txtFilterRange.Value)
    
    If s = "" Then
        If showMessage Then
            MsgBox "見出し範囲を入力してください。例: A1:C1", vbExclamation
        End If
        Exit Function
    End If
    
    On Error Resume Next
    Set rg = ws.Range(s)
    On Error GoTo 0
    
    If rg Is Nothing Then
        If showMessage Then
            MsgBox "見出し範囲が不正です。例: A1:C1", vbExclamation
        End If
        Exit Function
    End If
    
    If rg.Rows.Count <> 1 Then
        If showMessage Then
            MsgBox "見出し範囲は1行で指定してください。例: A1:C1", vbExclamation
        End If
        Exit Function
    End If
    
    Set GetHeaderRange = rg
End Function

Private Function GetFilterRangeFromHeader(ByVal headerRange As Range) As Range
    Dim ws As Worksheet
    Dim firstCol As Long
    Dim lastCol As Long
    Dim topRow As Long
    Dim lastDataRow As Long
    Dim c As Long
    Dim r As Long
    
    Set ws = headerRange.Worksheet
    
    firstCol = headerRange.Column
    lastCol = headerRange.Column + headerRange.Columns.Count - 1
    topRow = headerRange.Row
    lastDataRow = topRow
    
    For c = firstCol To lastCol
        r = ws.Cells(ws.Rows.Count, c).End(xlUp).Row
        If r > lastDataRow Then
            lastDataRow = r
        End If
    Next c
    
    Set GetFilterRangeFromHeader = ws.Range(ws.Cells(topRow, firstCol), ws.Cells(lastDataRow, lastCol))
End Function

Private Function GetDefaultHeaderRangeAddress() As String
    Dim ws As Worksheet
    Dim rg As Range
    
    Set ws = ActiveSheet
    
    On Error Resume Next
    If TypeName(Selection) = "Range" Then
        If Selection.Rows.Count = 1 Then
            Set rg = Selection
        End If
    End If
    On Error GoTo 0
    
    If rg Is Nothing Then
        Set rg = ws.Range("A1").CurrentRegion.Rows(1)
    End If
    
    GetDefaultHeaderRangeAddress = rg.Address(False, False)
End Function

Private Function ColumnLetter(ByVal colNum As Long) As String
    ColumnLetter = Replace(Cells(1, colNum).Address(False, False), "1", "")
End Function

Private Function EscapeFilterText(ByVal s As String) As String
    s = Replace(s, "~", "~~")
    s = Replace(s, "*", "~*")
    s = Replace(s, "?", "~?")
    EscapeFilterText = s
End Function

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        Cancel = True
        Me.Hide
    End If
End Sub

Private Sub RefreshFilterItems()
    Dim headerRange As Range
    
    Set headerRange = GetHeaderRange(True)
    If headerRange Is Nothing Then Exit Sub
    
    mLoading = True
    
    cboColumn.Clear
    cboValue.Clear
    txtKeyword.Value = ""
    
    LoadHeadersFromRange
    
    mLoading = False
    
    If cboColumn.ListCount > 0 Then
        LoadUniqueValues
    End If
End Sub

標準モジュール

Option Explicit

Public gFilterRange As String
Private Const FILTER_RANGE_NAME As String = "_frmFilterRange"

' フィルターウィンドウ表示
Public Sub ShowFilterForm()
    With frmFilter
        .StartUpPosition = 0
        .Left = Application.Left + (Application.Width - .Width) / 2
        .Top = Application.Top + (Application.Height - .Height) / 2
        .Show
    End With
End Sub

Public Function LoadSavedFilterRange() As String
    Dim s As String
    
    On Error Resume Next
    s = ThisWorkbook.Names(FILTER_RANGE_NAME).RefersTo
    On Error GoTo 0
    
    If s <> "" Then
        If Left$(s, 1) = "=" Then s = Mid$(s, 2)
        If Left$(s, 1) = """" And Right$(s, 1) = """" Then
            s = Mid$(s, 2, Len(s) - 2)
        End If
        s = Replace(s, """""", """")
    End If
    
    If Trim$(s) = "" Then s = "A1:C1"
    
    LoadSavedFilterRange = s
End Function

Public Sub SaveFilterRange(ByVal rangeText As String)
    Dim refersToText As String
    
    rangeText = Trim$(rangeText)
    If rangeText = "" Then Exit Sub
    
    refersToText = "=""" & Replace(rangeText, """", """""") & """"
    
    On Error Resume Next
    ThisWorkbook.Names(FILTER_RANGE_NAME).Delete
    On Error GoTo 0
    
    ThisWorkbook.Names.Add Name:=FILTER_RANGE_NAME, RefersTo:=refersToText
    ThisWorkbook.Names(FILTER_RANGE_NAME).Visible = False
End Sub
タイトルとURLをコピーしました