【Excel 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 SubVBAの基礎的な事は割愛させてもらって、検索処理のところだけを説明していきます。
まずは入力チェック
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).ColumnmaxRowに最終行、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もやってみようかなと思います。
おしゃれ度
★☆☆☆☆