【Excel VBA】検索ツールを作る

2021年4月18日VBA

急にVBA

はじめに

唐突にはじまりましたVBAコーナー。

webサイト制作やめたわけじゃないですよ。パソコンが限界みたいです。ChromeとかEdgeとかVSCodeとかGIMPとか、色々立ち上げてると重くて重くて。イライラするから新しいパソコン届くまで休憩します。

で、Excelだけならそこそこ動くのでVBAで便利ツールでも作ろうかなぁと思ったわけです。今回は検索ツールを作ってみます。

週刊 ガンダム・モビルスーツ・バイブル

定期購読してます。全100号で、いま現在89号まで。ここまで増えてくると大変なんですよね。

(サイコミュについて詳しく書かれてたアノ記事って何号に載ってたっけ…?)

こういう事よくありますよね。いますぐにサイコミュについて知りたいって時。だいたいのアタリつけて探すんですけど、まぁ時間かかる。たぶん定期購読してる人には需要があるんじゃないかと思って作りました。

準備

まずはデータをExcelに打ち込まないといけません。各号で扱っているモビルスーツ、パイロット、メカニックジャーナルを入力します。地味に大変ですが、これは手作業でがんばりましょう。ついでに検索用フォームみたいなのも作っておきます。

準備ができたらマクロを作成

検索処理のコードです。

Sub ClickSearchButton()
    '**********
    '検索ボタン
    '**********
    Dim dataSheet As Worksheet
    Dim keyword As String
    Dim maxRow As Long
    Dim maxCol As Long
    Dim msg As String
    Dim i As Long
    Dim j As Long
    
    If Range("B2") = "" Then
        MsgBox "検索したい語句を入力してください", vbExclamation
        Exit Sub
    End If
    
    Call ClearColor
    
    Set dataSheet = ThisWorkbook.Sheets("MS-Bible")
    
    With dataSheet
    
        keyword = Replace(StrConv(.Range("B2"), vbNarrow), " ", "")
        
        maxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        maxCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
        
        '========
        '検索処理
        '========
        For i = 5 To maxRow
            For j = 2 To maxCol
                If .Cells(i, j) <> "" Then
                    If Replace(StrConv(.Cells(i, j), vbNarrow), " ", "") Like "*" & keyword & "*" Then
                        '--------------------------------------------
                        '見つかったらセルを黄色にしてメッセージに追加
                        '--------------------------------------------
                        .Cells(i, j).Interior.Color = RGB(255, 255, 0)
                        msg = msg & i - 2 & "号" & vbCr
                        Exit For
                    End If
                End If
            Next
        Next
        
        '==============
        'メッセージ表示
        '==============
        If msg = "" Then
            MsgBox "見つかりませんでした", vbExclamation
        Else
            MsgBox msg & "に情報があります", vbInformation
        End If
        
    End With
    
End Sub

VBAの基礎的な事は割愛させてもらって、検索処理のところだけを説明していきます。

まずは入力チェック

If Range("B2") = "" Then
    MsgBox "検索したい語句を入力してください", vbExclamation
    Exit Sub
End If

キーワードを入力するセルが空欄だったらメッセージを出して終了します。なにもしません。

入力されたキーワードを半角に変換する

「サイコミュ」と「サイコミュ」は同じ文字として扱わないとユーザーはブチギレます。

たまに「全角で入力してください」とか注意書きしてる入力フォームがありますが、アレもどうかと思います。「そっちでなんとかしろよ」って言いたくなりますよね。なにか理由があるならごめんなさい。

keyword = Replace(StrConv(.Range("B2"), vbNarrow), " ", "")

“StrConv"関数の第二引数に"vbNarrow"を指定してあげれば、第一引数に渡した文字列が半角になります。

ついでに"Replace"関数でスペースも削除しておきます。そうしないと、うっかり入力されたスペースのせいで

「サイコミュ 」と「サイコミュ」

が違う文字として扱われてしまいます。細かい所ですが、ユーザーにストレスを与えないためには絶対に必要だと思います。決して「スペースなんか入力すんじゃねぇよ、このタコが」とか思ってはいけないのです。

表の最終行と最終列を取得

maxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
maxCol = .Cells(4, .Columns.Count).End(xlToLeft).Column

maxRowに最終行、maxColに最終列が入ります。これはよく使うので覚えておいた方がいいと思います。

入力されたキーワードを二重ループを使って探す

For i = 5 To maxRow
    For j = 2 To maxCol
        If .Cells(i, j) <> "" Then
            If Replace(StrConv(.Cells(i, j), vbNarrow), " ", "") Like "*" & keyword & "*" Then
                '--------------------------------------------
                '見つかったらセルを黄色にしてメッセージに追加
                '--------------------------------------------
                .Cells(i, j).Interior.Color = RGB(255, 255, 0)
                msg = msg & i - 2 & "号" & vbCr
                Exit For
            End If
        End If
    Next
Next

二重ループを使って、表の中の「全てのセルのデータ」と「入力されたキーワード」を比較し、部分一致するかどうかを判定します。Excelは行と列の表形式になっているので、二重ループとの相性がとても良いです。

検索する時にセルのデータも変換する

If Replace(StrConv(.Cells(i, j), vbNarrow), " ", "") Like "*" & keyword & "*" Then

部分一致の条件文だけ抜粋したものです。

セルのデータもキーワードと同じように、半角に変換してスペースを取り除いてあげます。

キーワードだけ「サイコミュ」でセルが「サイコミュ」のままだと一致しません。必ず「同じ状態に変換」して比較してあげるという事を忘れてはいけません。

“keyword"の前後にくっつけた"*"(アスタリスク)は「0文字以上の任意の文字」を表します。これとLike演算子を組み合わせると、「セルの文字列の中にキーワードが含まれているか」という部分一致の条件を作ることができます。

思いやる気持ち

検索したいキーワードはまず日本語でしょう。入力欄にフォーカスがあたった時、自動で日本語入力になるようにしてあげるとモテます。そのためには、「データ」タブの「入力規則」から日本語入力を「オン」にしてあげます。

「半角/全角キー」を押す手間が省けてユーザーはニッコリ。

見つけやすくしてあげる

「シャア」で検索した結果です↓。

.Cells(i, j).Interior.Color = RGB(255, 255, 0)

検索でヒットしたセルに色をつけてあげれば見つけやすくなりますね。常に相手のことを思いやる。これがモテる秘訣です。

あとがき

webサイトのお問い合わせフォームを作るときにも気を付けたいですね。

また機会があればVBAもやってみようかなと思います。

おしゃれ度

★☆☆☆☆

Posted by ナカタ