エクセルでグーグルサジェストっぽい入力をする

参考サイト：主に言語とシステム開発に関して

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

続く　エクセルでグーグルサジェストっぽい入力をする（２）