【知らなくても使える】テーブル内のデータを項目毎に検索して表示するマクロツール（Excel VBA）

Option Explicit

'---------（設定値）---------------------------
Private Const KEYWORD_ROW = 7                   '１．検索ワードを入力する行番号
Private Const HEAD_ROW = 10                     '２．テーブル見出し行の行番号
Private Const HEAD_COL_NUM = 1                  '３．テーブル見出し行の列番号
Private Const SEARCH_TYPE_POINT = "B3"          '４．検索条件を指定するセル（AND検索、OR検索）
Private Const SEARCH_TYPE2_POINT = "C3"         '５．検索条件を指定するセル（完全一致、部分一致）
Private Const SETTING_SHEET_NM = "setting"      '６．設定シートの名称
Private Const WORK_COL_NM = "作業列"            '７．設定シートの名称

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

Dim SearchType1 As String
Dim SearchType2 As String
Dim HeadCellPoint As String
Dim DataCellPoint As String
Dim WorkColNum As Long              '作業列の列番号
Dim WorkCol As String               '作業列
Dim BaseSht As Worksheet            'ツールの本体シート
Dim SettingSht As Worksheet         '設定シート

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

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
        
    Set BaseSht = 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
    
    ''設定情報を取得する
    Call GetSetting
    
    ''色の変更、作業行の初期化等を行う
    Call ClearSheetColor
    
    If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
        Range(HeadCellPoint).AutoFilter
    End If
    
    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(BaseSht.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
        BaseSht.Range(HeadCellPoint & ":" & WorkCol & Format(HEAD_ROW)).AutoFilter Field:=WorkColNum, 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 iRow
    Dim iCol
    
    iRow = Cells(Rows.Count, 1).End(xlUp).Row
    iCol = Cells(HEAD_ROW, HEAD_COL_NUM).End(xlToRight).Column
    
    BaseSht.Range(Range(DataCellPoint), Cells(iRow, iCol)).Font.ColorIndex = 1
    BaseSht.Range(WorkCol & HEAD_ROW + 1 & ":" & WorkCol & iRow).Clear
    
End Sub

'-------------------------------------
'設定情報を取得する
'-------------------------------------
Sub GetSetting()

    Set SettingSht = Worksheets(SETTING_SHEET_NM)
    Dim workColNm As String
    
    Dim c As Range
    Set c = Cells(HEAD_ROW, HEAD_COL_NUM).CurrentRegion
    
    '最終列の列番号と列を取得する
    WorkColNum = c.Columns(c.Columns.Count).EntireColumn.Column
    workColNm = BaseSht.Cells(HEAD_ROW, WorkColNum).Value
    
    HeadCellPoint = Split(Cells(1, HEAD_COL_NUM).Address, "$")(1) & HEAD_ROW
    DataCellPoint = Split(Cells(1, HEAD_COL_NUM).Address, "$")(1) & HEAD_ROW + 1
    
    '最終列の項目名が「作業列」でない場合は作業列を新たに作る
    If WORK_COL_NM <> workColNm Then
        WorkColNum = BaseSht.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
        BaseSht.Cells(HEAD_ROW, WorkColNum).Value = WORK_COL_NM
    End If
    
    '検索対象が表でなくテーブルで記載されている場合の対応
    If BaseSht.ListObjects.Count <> 0 Then
        If BaseSht.Range(HeadCellPoint).ListObject.Range.Columns.Count <> WorkColNum Then
    
            '作業列がテーブル内に入っていない場合は、追加する
            With BaseSht.Range(HeadCellPoint).ListObject
                .Resize .Range.Resize(, .Range.Columns.Count + 1)
            End With
        End If
    End If

    WorkCol = Split(Cells(1, WorkColNum).Address, "$")(1)
    
    '作業列が非表示になっていない場合は、非表示にする
    If Columns(WorkColNum).Hidden <> True Then Columns(WorkColNum).Hidden = True
    
    '検索条件を取得する
    SearchType1 = SettingSht.Range(SEARCH_TYPE_POINT).Value
    
    '条件の対象を取得する
    SearchType2 = SettingSht.Range(SEARCH_TYPE2_POINT).Value
    
End Sub