Excel VBA 蓄積データ検索マクロ（コピペで使える便利機能）

Option Explicit

Private Const KeywordPoint = "D2"
Private Const StartRow = 5
Private Const WorkCol = "K"
Private Const TableCell = "A4"
Private Const TableCellNohead = "A5"
Private Const WorkColRow = "K5:K"

Private Const SearchTgtCol = "D,E,F,J"        '検索対象の列をカンマ区切りで指定する

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

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    If Range(KeywordPoint).Value = "" Then
    
        MsgBox "検索ワードを入力してください。"
        Exit Sub
    
    Else
        Call ClearSheetColor
        
        Dim sht As Worksheet
        Set sht = ActiveSheet
        
        Dim lastRow, iRow, iCol
        
        Dim keyword As Variant
        Dim keywordArr As Variant
        Dim tgtCol() As String
        Dim tgtWord(1) As String
        Dim searchResult() As String
        
        Dim blnExist As Boolean: blnExist = True

        '「D2」における検索ワードを取得する
        keyword = Worksheets(sht.Name).Range(KeywordPoint).Value
        
        '検索ワードの間にスペースがあった場合は文字を分割して格納する
        keyword = Replace(keyword, "　", " ")
        keywordArr = Split(keyword)
        
        '検索対象の列を格納する
        tgtCol = Split(SearchTgtCol, ",")
        
        lastRow = sht.UsedRange.Rows.Count + sht.UsedRange.Row - 1
        
        '検索対象の行がある分だけ繰り返す
        For iRow = StartRow To lastRow
        
            '検索対象の列がある分だけ繰り返す
            For iCol = 0 To UBound(tgtCol)
                
                tgtWord(1) = Range(tgtCol(iCol) & iRow).Value
                
                For Each keyword In keywordArr
                    
                    searchResult = Filter(tgtWord, keyword)
                    
                    If UBound(searchResult) = -1 Then
                        blnExist = False
                        Exit For
                        
                    End If
                    
                Next keyword
                
                If blnExist Then
                    Range(WorkCol & iRow).Value = "1"
                    Range(tgtCol(iCol) & iRow).Font.Color = RGB(255, 0, 0)
                End If
                
                blnExist = True
            
                Erase tgtWord, searchResult
            
            Next iCol
            
        Next iRow
        
        sht.Range("A4:K4").AutoFilter Field:=11, Criteria1:="<>"
        
    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
    
    Call ClearSheetColor
    If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
    
        Range(TableCell).AutoFilter
'        ActiveSheet.ShowAllData
    End If
    
    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 = sht.UsedRange.Rows.Count + sht.UsedRange.Row - 1
    iCol = sht.UsedRange.Columns.Count + sht.UsedRange.Column - 1
    
    sht.Range(Range(TableCellNohead), Cells(iRow, iCol)).Font.ColorIndex = 1
    
    sht.Range(WorkColRow & iRow).Clear
    
End Sub