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

 

Excelのテーブル(表)内の各項目の値をそれぞれ指定して検索したいと思ったことはないでしょうか。

 

その際には、エクセルで管理したデータを検索するときにエクセル機能の「検索」を何度も実行して、対象のデータがある行を確認しては、再度検索、検索、検索…というように非常に手間がかかる作業をしている方も多くいらっしゃるのではないでしょうか。

 

そんな時に、一度の実行で対象のデータがある行が検索できるツール『テーブル内の各項目データ検索ツール』をExcelマクロで作成しました。

 

これを使用すれば定例業務の業務効率化が図れるかと思いますので、是非ご活用頂けたらと思います。

 

 

また、このツールのように各項目毎に検索条件を設定して検索するのでなく、複数項目に対して一つの検索条件で検索したい場合は、以下のツールを使用してみてください。

 

 

『テーブル内の各項目データ検索ツール』の概要

エクセルの表を作成し、その中に日々業務で使用したデータを入れ込んでいきます。

 

そのデータが蓄積された際に、各項目を対象とした検索ワードを入れて、検索を実行すれば対象セルのみが赤く表示され、検索対象が一度で容易に確認できるようになります。

 

下に説明動画を載せますので、ご確認ください。

動画を見ると分かりやすいと思います。

 

<説明動画>

現在準備中…

 

当ツールの使用方法

基本的な機能、操作方法の説明

1.実行するマクロが入ったExcelファイル(当ツールのマクロ付き)を開きます。

2.対象の表内に検索したいデータを入れた状態にします。(この表から検索をします)

 

3.各項目を対象にした検索ワードを6行目のセルに文字を入力して、「検索」ボタンを押します。

 

入力した検索ワードに一致する値があるセルが赤色で表示され、対象の行のみ表示されます。

 

(補足)

オプションとして、検索する際の条件を指定でき、検索結果の違いは以下になります。

 

各項目の検索

複数項目を入力した際の検索条件を下記の二つから指定できます。

  • AND条件:各項目の検索ワードが全て当てはまる行を表示する
  • OR条件:各項目の検索ワードが一つでも当てはまる行を表示する

(※複数の項目に値が入力された場合にAND条件またはOR条件で表示されます)

 

セル内の検索条件

一つの項目内の検索条件を以下の二つから指定します。

  • 部分一致:それぞれの項目に入力した値の一部が一致する行を表示する
  • 完全一致:それぞれの項目に入力した値が全て一致する行を表示する

 

留意事項

検索ワード内のワイルドカード等の使用

検索ワード内に空白やワイルドカードの対応していませんので、その場合は、オプションにある「各項目の検索」を『部分一致』にして検索してください

 

表の項目の列数を変更する場合

現行のツールでは表の列が「J列」までで作成されていますが、項目数を増減する場合は、以下の対応をしてください。

項目を減らす場合

 

項目を増やす場合

 

使用する際の事前準備

このページの下部にある「Excelファイルのツール」からExcelファイルを取得し、「準備の手順」内にあるVBAコードを取得したExcelファイルに記載して保存すれば、すぐに当ツールを使用できます。

 

以下にその手順を説明していきます。

 

準備の手順

1.当ツールのダウンロードはこちら」からサンプル(Excelファイル)をダウンロードします。

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、設定画面(設定シート)が入っているマクロ無しExcelファイルを公開しています

 

2.ダウンロードしたExcelファイルの上部にあるリボンの「開発」タブから「visual basic」を選択して、VBE(visual basic for application)を起動させます。

 

3.「Microsoft Excel Object」にて右クリックして「標準モジュール」を挿入します。

 

4.新しくできた「Module1」を選択して、右側の空欄スペース(エディター)に下記のVBAコードをコピペで入力します。

 

VBAのソースコードはこちら

以下のVBAコードをコピーして、「Module1」内のエディターに貼り付けます。

※VBAコードの右上のアイコンをクリックするとソースコードをコピーできます

Option Explicit

'---------(設定値)---------------------------
Private Const KEYWORD_ROW = 6                   '1.検索ワードを入力する行番号
Private Const HEAD_ROW = 9                      '2.テーブル見出し行の行番号
Private Const HEAD_COL_NUM = 1                  '3.テーブル見出し行の列番号
Private Const WORK_COL_NUM = 11                 '4.作業列の列番号
Private Const SEARCH_TYPE_POINT = "J4"          '5.検索条件を指定するセル(AND検索、OR検索)
Private Const SEARCH_TYPE2_POINT = "H4"         '6.検索条件を指定するセル(完全一致、部分一致)

'---------(メッセージ)-----------------------
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

 

作成したExcelファイルを「.xlsm」形式(マクロが動作するファイル形式)で保存します。

 

6.Excelファイル内にある「検索」ボタンと「フィルター解除」ボタンに対して、右クリック→「マクロの登録」を押します。

 

「検索」ボタンには「検索_Click」を指定して、「OK」を押します。

 

「フィルター解除」ボタンには「フィルター解除_Click」を指定して、「OK」を押します。

 

各ボタンに対して正常にマクロが登録できた場合は、マウスをボタンの上に持っていくと「指のマーク」に変化します

 

これで事前準備は完了です。

あとは「当ツールの使用方法」で記載された方法でツールを実行できます。

 

また、このようなExcelVBAを用いた業務効率化を行うときに、以下の書籍が初心者向けでとても参考になると思いますので、良かったらご参照ください。

 

なお、当マクロの開発環境として、OSは “Windows10” 、Excelのバージョンは “Microsoft Office 365″ で行っており、当環境では動作確認ができていますが、他のすべての環境で正常に動作するかは確認できていません。

 

正常に動作しない場合は、コメントいただければ幸いです。
 

また、このような業務効率化できるツールを以下に一覧でまとめてありますので、ご興味のある方はご覧ください。

 

当ツールのダウンロードはこちら

下記よりExcelファイルをダウンロードして、記事の途中にありました VBAのソースコードをツール内に組み込んで使用してください。

 

【Excel VBA】テーブル内の各項目データ検索ツール

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています

 

他に要望等ありましたら、可能な限り改修等を対応しますのでコメント頂ければと思います

 

<このツールが『結構使える!』と思ったら、下のグッドボタンを押していただけたら幸いです>

コメントを残す

CAPTCHA