Google 検索の「サジェスト機能」を， Excel のシート上にVBAで作る （セルの内容に応じて入力規則を動的に変える方法）
Googleの検索窓には，検索候補のサジェスト機能がある。
- １文字「山」と入力したら，「山田」「山川」などの候補をドロップダウンで表示。
- 同じく「石」と入力したら，「石田」「石川」などの候補をドロップダウンで表示。
最初の一文字だけ入力すればよい。 楽だし，ミスタイプもない。
これと同じことを，Excelでも実現してみる。
これは便利！！
記事を参考に試してみたら、うまくいく場合とエラーになってしまう場合があった。
入力規則のFormula1に直接突っ込める文字数は255文字までの制限があるらしい。
このエラーを回避するため、配列に格納した文字列を一旦適当なシートに書き出し、それに名前をつけて入力規則で参照するようにコードを変更した。
参考サイト：配列をセルに代入する Office TANAKA
【Step１】
入力・郵便番号データ・リスト用という３つのシートを作成する。
※シート名の変更でも可
【Step２】
VBEの標準モジュールにコードを記述
VBEを起動（Alt+F11)
メニュー 挿入 標準モジュールで標準モジュールを挿入
挿入したModuleをダブルクリックしコードを記述
Sub 入力規則リスト(str As String, cSh As Worksheet)
Dim buf As String, tmp As Variant
Dim Sh As Worksheet
Range("リスト").ClearContents
buf = str
tmp = Split(buf, ",")
Set Sh = Worksheets("リスト用")
Sh.Activate
Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)) = WorksheetFunction.Transpose(tmp)
Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)).Name = "リスト"
cSh.Activate
End Sub
【Step３】
メインのプロシージャをさきほどの標準モジュールに追記する
（下のSubからEnd Subまでをさきほどの続きにコピーして貼り付ける）
Sub 入力候補表示(Sh As String, Rg As String, Tg As Range)
Dim foundCell As Variant
Dim listSheet As String '辞書のシート名
Dim strDictionary As String '辞書の範囲
Dim matchKey As String
Dim strFormula As String ' 入力規則に入れる文字列
Dim firstAddress As String ' 最初の結果のアドレス
Dim matchWord As String
Dim roopCount As Long
Dim lngY As Long, intX As Long
If Tg.Count > 1 Then Exit Sub
' アクティブセルの値が辞書に載っているか検索
listSheet = Sh ' 検索対象シート
strDictionary = Rg ' 検索対象範囲
matchKey = Tg.Value
'部分一致で検索する（完全一致での検索を回避）
Set foundCell = Worksheets(listSheet).Range(strDictionary).Find( _
What:=matchKey, LookAt:=xlPart)
' 検索結果が空の場合終了
If foundCell Is Nothing Then Exit Sub
' 検索結果を回す
strFormula = ""
roopCount = 0
firstAddress = foundCell.Address
Do
' 辞書から入力候補を収集
lngY = foundCell.Cells.Row
intX = foundCell.Cells.Column
matchWord = Worksheets(listSheet).Cells(lngY, intX).Value
'比較
If InStr(matchWord, matchKey) > 0 Then
strFormula = strFormula & matchWord & ","
End If
roopCount = roopCount + 1
' 次の入力候補へ
Set foundCell = Worksheets(listSheet).Range(strDictionary).FindNext(foundCell)
Loop While (Not foundCell Is Nothing) And (firstAddress <> foundCell.Address)
' 入力候補をセット
Application.EnableEvents = False
If roopCount = 1 Then
'候補が一つの場合、それを入力
If Tg = "" Then 'エラー処理
Application.EnableEvents = True
strFormula = ""
Tg.Select
Exit Sub
Else
Tg.Value = Left(strFormula, Len(strFormula) - 1)
End If
ElseIf Len(strFormula) > 0 Then
'リストという名前の範囲を生成し配列を代入する
Application.ScreenUpdating = False
Call 入力規則リスト(strFormula, ActiveSheet)
Application.ScreenUpdating = True
'候補が複数ある場合は、候補のリストを表示
On Error GoTo ErrorHandler
With Tg.Validation '入力規則を設定
.Delete
.Add Type:=xlValidateList, Formula1:="=リスト"
.ShowError = False
.InCellDropdown = True
End With
Tg.Select
SendKeys "%{DOWN}"
End If
Set foundCell = Nothing
strFormula = ""
Application.EnableEvents = True
ErrorHandler:
Application.EnableEvents = True
strFormula = ""
End Sub
※入力候補が一つしかヒットしないときは、ドロップダウンして選択する手順をスキップします。
【Step４】
プロジェクトエクスプローラ（非表示の場合Ctrl+Rで表示）のイベントを起こしたいシート（シート名：入力)をダブルクリック し、下のコードを記述する
Private Sub Worksheet_Change(ByVal target As Range)
'辞書（住所の候補）を設定する：郵便番号データから候補表示
'DicSheetNameは辞書のシート名、
'DicRangeAddressは辞書の範囲を指定する
'
Const DicSheetName = "郵便番号データ"
Const DicRangeAddress = "A:A"
If target.Count > 1 Then
'選択セルが２つ以上は無効
Set target = Nothing
Exit Sub
ElseIf Application.Intersect(target, Range("A4")) Is Nothing Then
'※入力セル以外の変更では無効(targetと共有するセル範囲がない）
Exit Sub
Else
'入力されたアドレスが住所入力のアドレスの場合に候補を表示
Call 入力候補表示(DicSheetName, DicRangeAddress, target)
End If
End Sub
※一つのセルだけでなく、複数のセルでイベントを起こしたい場合は、ElseIf Application.Intersect(target, Range("A4")) Is Nothing ThenのA4をA4:A10等の範囲に書き換える等の方法があります。
例）Application.Intersect(target, Range("A4：A10")) Is Nothing Then
