【Excel VBA】テーブル内の各項目データ検索ツール（コピペですぐ使える）

Option Explicit

'---------（設定値）---------------------------
Private Const KEYWORD_ROW = 6                   '１．検索ワードを入力する行番号
Private Const HEAD_ROW = 9                      '２．テーブル見出し行の行番号
Private Const HEAD_COL_NUM = 1                  '３．テーブル見出し行の列番号
Private Const WORK_COL_NUM = 11                 '４．作業列の列番号
Private Const SEARCH_TYPE_POINT = "J4"          '５．検索条件を指定するセル（AND検索、OR検索）
Private Const SEARCH_TYPE2_POINT = "H4"         '６．検索条件を指定するセル（完全一致、部分一致）

'---------（メッセージ）-----------------------
Private Const Msg2 = "検索対象が見つかりませんでした。"
'----------------------------------------------

Dim SearchType1 As String
Dim SearchType2 As String
Dim HeadCellPoint As String
Dim DataCellPoint As String
Dim WorkCol As String

'===============================================
'項目をまたいで検索ボタンを押した時に実行される検索メイン処理
'===============================================
Sub 検索_Click()

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Dim sht As Worksheet
    Set sht = ActiveSheet
    
    Dim lastRow, lastColumn, iRow, iCol
    
    Dim keyword As Variant
    Dim tgtWord(1) As String
    Dim searchResult() As String
    Dim searchResult2 As Integer
    
    Dim blnSearchExist As Boolean: blnSearchExist = False
    
    Dim keywordCnt As Long
    Dim findCnt As Long
    
    WorkCol = Split(Cells(1, WORK_COL_NUM).Address, "$")(1)
    HeadCellPoint = Split(Cells(1, HEAD_COL_NUM).Address, "$")(1) & HEAD_ROW
    DataCellPoint = Split(Cells(1, HEAD_COL_NUM).Address, "$")(1) & HEAD_ROW + 1
    
    '検索条件を取得する
    SearchType1 = Worksheets(sht.Name).Range(SEARCH_TYPE_POINT).Value
    SearchType2 = Worksheets(sht.Name).Range(SEARCH_TYPE2_POINT).Value
    
    If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
        Range(HeadCellPoint).AutoFilter
    End If
    Call ClearSheetColor
    
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    lastColumn = Cells(HEAD_ROW, HEAD_COL_NUM).End(xlToRight).Column
    
    '検索対象の行がある分だけ繰り返す
    For iRow = HEAD_ROW + 1 To lastRow
        
        keywordCnt = 0
        findCnt = 0
        
        '検索対象の列がある分だけ繰り返す
        For iCol = 1 To lastColumn
            
            keyword = Worksheets(sht.Name).Cells(KEYWORD_ROW, iCol).Value
            
            If keyword <> "" Then
            
                keywordCnt = keywordCnt + 1
                tgtWord(1) = Cells(iRow, iCol).Value
                
                '完全一致で検索する場合
                If InStr(SearchType2, "完全") <> 0 Then
                    searchResult2 = StrComp(tgtWord(1), keyword)
                    
                    If searchResult2 = 0 Then
                        Cells(iRow, iCol).Font.Color = RGB(255, 0, 0)
                        findCnt = findCnt + 1
                    End If
                    
                '部分一致で検索する場合
                Else
                    searchResult = Filter(tgtWord, keyword)
                    
                    If UBound(searchResult) <> -1 Then
                        Cells(iRow, iCol).Font.Color = RGB(255, 0, 0)
                        findCnt = findCnt + 1
                    End If
                End If
            End If
        Next
        
        'AND条件で検索する場合
        If InStr(SearchType1, "AND") <> 0 Then
            If keywordCnt = findCnt Then
                Range(WorkCol & iRow).Value = "1"
                blnSearchExist = True
            End If
            
        'OR条件で検索する場合
        Else
            If findCnt > 0 Then
                Range(WorkCol & iRow).Value = "1"
                blnSearchExist = True
            End If
        End If
    Next
        
    '検索対象が存在する場合はフィルターし、存在しない場合はメッセージを表示させる
    If blnSearchExist Then
        sht.Range(HeadCellPoint & ":" & WorkCol & Format(HEAD_ROW)).AutoFilter Field:=WORK_COL_NUM, Criteria1:="<>"
    Else
        Call ClearSheetColor
        MsgBox Msg2
    End If
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
End Sub

'===================================================================
'フィルター解除ボタンを押した時に実行されるフィルター解除メイン処理
'===================================================================
Sub フィルター解除_Click()

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    HeadCellPoint = Split(Cells(1, HEAD_COL_NUM).Address, "$")(1) & HEAD_ROW
    
    If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
        Range(HeadCellPoint).AutoFilter
    End If
    
    Call ClearSheetColor
        
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
End Sub

'-------------------------------------
'色の変更、作業行の初期化等を行う
'-------------------------------------
Sub ClearSheetColor()
    
    Dim sht As Worksheet
    Set sht = ActiveSheet
    
    Dim iRow
    Dim iCol
    
    iRow = Cells(Rows.Count, 1).End(xlUp).Row
    iCol = Cells(HEAD_ROW, HEAD_COL_NUM).End(xlToRight).Column
    
    sht.Range(Range(DataCellPoint), Cells(iRow, iCol)).Font.ColorIndex = 1
    sht.Range(WorkCol & HEAD_ROW + 1 & ":" & WorkCol & iRow).Clear
    
End Sub