Excelでサジェスト機能実装！入力途中で指定したリストから予測変換を行う

Sub 入力規則リスト(str As String, cSh As Worksheet)
    Dim buf As String, tmp As Variant
    Dim Sh As Worksheet
On Error Resume Next
Range("リスト").ClearContents
On Error GoTo 0
    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

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 = "辞書" ' 検索対象シート

    strDictionary = "A:A"  ' 検索対象範囲

    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}"
　　　　Call numlock_onoff
    End If

    Set foundCell = Nothing
    strFormula = ""
    Application.EnableEvents = True

ErrorHandler:
    Application.EnableEvents = True
    strFormula = ""
End Sub

'======================================================
'   SendkeysでNumlockがOFFになるバグを回避する
'　　　WSH(Windows Scripting Host)
'======================================================
 
Sub numlock_onoff()
    Dim WshShell
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.SendKeys "{NUMLOCK}"
    Set WshShell = Nothing
End Sub

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("A:A")) Is Nothing Then
      '※サブジェスト適用範囲を"A:A"で指定している
      '※入力セル以外の変更では無効(targetと共有するセル範囲がない）
         Exit Sub
   
     Else
         '入力されたアドレスが住所入力のアドレスの場合に候補を表示
             Call 入力候補表示(DicSheetName, DicRangeAddress, target)
     End If
     
End Sub