No title
VBA
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'入力規則のリストにサジェスト機能を実装。
'入力した文字をリストデータから探し、部分一致したデータをリストとして表示する。
'入力セルを空白にした（削除した）場合はリストの全データを設定する。表示はしない。
'部分一致したデータを表示するために「検索候補シート」を作業用として使用。
'対象セル以外のセルへの入力時はマクロを終了させる
If Target.Count > 1 Then Exit Sub
If Target.Address <> Range("B5").Address Then Exit Sub
'イベントの抑制と対象セルの入力規則の削除
Application.EnableEvents = False
Target.Validation.Delete
'シートオブジェクト・レンジオブジェクトの宣言---------------------------------------------------
Dim listWs As Worksheet
Dim listArea As Range
Dim lastRow As Long
Dim hitWs As Worksheet
Dim hitArea As Range
Set listWs = Sheets("リスト")
lastRow = listWs.Cells(Rows.Count, 1).End(xlUp).Row
Set listArea = listWs.Range(listWs.Cells(2, 1), listWs.Cells(lastRow, 1))
Set hitWs = Sheets("検索候補")
Set hitArea = hitWs.Range("A:A")
hitArea.ClearContents
'-----------------------------------------------------------------------------------------------
'以降3つに分岐
'①そもそも入力した文字がリストのデータのいずれかと完全一致している場合
'リストを表示せずに終了
'②入力セルが空白の場合
'リストの全データを設定する。表示はしない
'③上記以外
'部分一致したリストを表示させる
'①----------------------------------------------------------------------------------------------
If Not IsError(Application.Match(Target.Value, listArea, 0)) Then
Application.EnableEvents = True
Exit Sub
End If
'------------------------------------------------------------------------------------------------
'②----------------------------------------------------------------------------------------------
If Target.Value = "" Then
Target.Validation.Add Type:=xlValidateList, Formula1:="=" & listArea.Address(external:=True)
Target.Validation.ShowError = False
Application.EnableEvents = True
Exit Sub
End If
'------------------------------------------------------------------------------------------------
'③----------------------------------------------------------------------------------------------
'方法
'InStr関数を使用し、リストデータ内に入力した文字が含まれているか上から確認していく。
'※InStr関数にはvbTextCompareを適用(カナ,かな 全角半角 大文字,小文字を区別しないようにするため)
'含まれていたら、そのデータを「検索候補シートのA列」に列記していく。
'最後に、入力セルに「検索候補シートのA列」をリストとして設定する。
If Target.Value <> "" Then
Dim rng As Range
Dim cnt As Long
Dim Hits As String
For Each rng In listArea
If InStr(1, rng.Value, Target.Value, vbTextCompare) > 0 Then
cnt = cnt + 1
hitArea(cnt).Value = rng.Value
End If
Next
Target.Validation.Add Type:=xlValidateList, Formula1:="=" & hitArea.Address(external:=True)
Target.Validation.ShowError = False
End If
'-----------------------------------------------------------------------------------------------
'入力セルを選択し、リストを表示する
Target.Select
SendKeys "%{Down}"
'イベント抑制の解除
Application.EnableEvents = True
End Sub