予測変換入力

エクセルで事務を楽にするプログラマーmoimoiです。
エクセルで一覧に入力する作業を行う場合に、楽に入力するために
入力規則を指定したり、今まで入力したものをAlt＋↓キーで入力してみたり
ただ、入力の選択肢が多くなると、選択するのも大変になってしまうことはないでしょうか？

今回は、選択肢を予測で絞り込みリストを出してくれるようにする方法をご紹介します。

【コード】

①前準備用マクロ

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 = TruestrFormula = ""
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
     '入力されたアドレスが住所入力のアドレスの場合に候補を表示
         ActiveSheet.Unprotect
         Call 入力候補表示(DicSheetName, DicRangeAddress, target)
         ActiveSheet.Protect
 End If
End Sub

【設定方法】

１．モジュールを作成

２．①②をモジュールに記載

３．予測変換したいシートに③を記載

４．コードに列・シートに指定を修正

５．空のリストシートを作成

６．入力規則用のリストを入力したシートを作成

【使い方】

１．予測変換したい列のセルに入力規則、6で作成したリスト形式を設定

２．一部入力＋EnterもしくはAlt＋↓で入力が容易になります。
※入力は必ずしも最初の文字からでなくてOKです。