1.概要
短縮語を入力すると対応リストから入力規則を作成し表示するプログラム
・入力候補は結果の画像のように、イニシャル(短縮語)とセットでデータを作成しておく。
・短縮語無しで入力候補のみでも可。その場合はMakeDropDownList関数の第3引数を1に変更する。
2.ソースコード
2.1 シートモジュールのコード
以下のコードをシートのモジュールに入力する。
当コードはWorksheet_Changeイベントであるため、シートが編集されるたびに実行される。
※ 2019/1/18:誤記訂正、ついでに候補件数が1の場合それを自動適用するように変更
Option Explicit
'1列目のセル内容変更時に入力規則を設定
Private Sub Worksheet_Change(ByVal arg_rg As Range)
On Error GoTo err '念のためエラー処理
'------入力列が対象範囲外(今回は1列目)でない場合終了------
If arg_rg.Column <> 1 Then: Exit Sub
'------前回実行結果との比較 後述の ※ を実行した際の無限ループ対策------
Static PrevResult As String '前回の結果を保持
If arg_rg = PrevResult Then: Exit Sub
'------入力列が対象範囲内の場合ドロップダウンリストを設定------
arg_rg.Select '編集セルを再選択(Enterすると下にズレるため)
Dim rg_dic As Range '入力候補が設定された範囲
Set rg_dic = Range("C3:D8")
Dim resultCount As Long 'ドロップダウンの設定に成功したか判定
'セルにドロップダウン設定(ドロップダウンに適用するのは2列目)
resultCount = MakeDropDownList(arg_rg, rg_dic, 2)
'------ドロップダウンリスト設定後の処理------
If resultCount = 0 Then '候補が見つからず、リストを作成出来なければ終了
Exit Sub
'※候補が1個であればそれをセルに適用
'※適用時にWorksheet_Changeを再起するので冒頭で前回の結果を確認し無限ループを防いでいる
ElseIf resultCount = 1 Then
PrevResult = arg_rg.Validation.Formula1 '※今回の結果を格納
arg_rg.Value = PrevResult
ElseIf resultCount >= 2 Then '候補が2個以上であればAlt+↓でリストを開く
SendKeys "%{DOWN}"
End If
err:
End Sub
2.2 標準モジュールのコード
第一引数の文字列を第二引数内で検索し、第一引数のドロップダウンリストに設定する関数。
'rg_targetの値をrg_dicからFind→ヒットしたものでrg_targetにドロップダウンリストを設定(以下サジェスト)
'arg_colはrg_dicのどの列をリストに使うかのオプション。うまく使えばイニシャルを打ち込むだけで動作する(既定は1)
Function MakeDropDownList(rg_target As Range, rg_dic As Range, Optional arg_col As Long = 1) As Boolean
Dim rg_find As Range '見つかったセルのバッファ
Set rg_find = AllFind(rg_target.Value, rg_dic) '「すべて検索」
'見つからなければ終了
If rg_find Is Nothing Then
MakeDropDownList = False
Exit Function
End If
'-------見つかった場合-------
Dim str_Suggest As String 'サジェストのバッファ
Dim row_ As Long '検索でヒットした行(rg_dicの左上基準)
Dim buf As Range 'foreach用
'ヒットしたセルをループ(Unionでバラバラなのでforeachがよい)
For Each buf In rg_find
row_ = buf.Row - rg_dic.Row + 1 '検索でヒットした行(rg_dicの左上基準)を格納
str_Suggest = str_Suggest & rg_dic(row_, arg_col) & "," '辞書の指定列のものをサジェストに加える
Next
'サジェストを適用
With rg_target.Validation
.Delete '既存のサジェストを削除
.Add xlValidateList, Formula1:=str_Suggest 'サジェストを登録
.ShowError = False 'エラーは出さない(どっちでもいいが)
End With
MakeDropDownList = True
End Function
'「すべて検索」の関数
Function AllFind(findstr As String, findRegion As Range) As Range
Dim firstFound As Range '最初に見つかったセル
Set firstFound = findRegion.Find(findstr)
'1つも見つからなければNothing
If firstFound Is Nothing Then
Set AllFind = Nothing
Exit Function
End If
'-----2つ目以降を検索する処理-----
Dim tempFound As Range '見つかったセルをの一時バッファ
Dim result_ As Range 'return用
'それぞれに最初に見つかったセルをセット
Set tempFound = firstFound
Set result_ = tempFound
Do
'前回の検索結果以降を検索
Set tempFound = findRegion.FindNext(tempFound)
'最初のアドレスに戻ってきたらループ終了
If tempFound.Address = firstFound.Address Then
Exit Do
Else
'returnに加える
Set result_ = Union(result_, tempFound)
End If
Loop
Set AllFind = result_
End Function
3.出力結果
一列目に短縮語を入力すると対応する名前がドロップダウンリストで表示される。