作業環境
Windows10、Excel2016
実現させたいこと
水泳大会で新記録が出たときに発行する記録証ファイルを作成しています。
記録証には、出場者氏名・新記録を出した出場種目等を記載します。
出場者氏名は下記2つのコードを使用して、サジェスト機能的な方法で入力します。
このとき、別のシート(下記のPersonシート)にある該当者の出場種目(1種目または2種目)をプルダウンリストで入力したいのです。
エクセル既存の機能、関数、VBA、なるべく簡単な方法を教えて戴けるとたいへん有難いです。
出場者氏名を入力するためのコード
1.標準モジュールに下記のコードを記述
vba
1Sub 入力規則リスト(str As String, cSh As Worksheet) 2 Dim buf As String, tmp As Variant 3 Dim Sh As Worksheet 4 Range("A:A").ClearContents 5 buf = str 6 tmp = Split(buf, ",") 7 Set Sh = Worksheets("配列格納") 8 Sh.Activate 9 Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)) = WorksheetFunction.Transpose(tmp) 10 Sh.Range(Cells(1, 1), Cells(UBound(tmp), 1)).Name = "リスト" 11 cSh.Activate 12End Sub 13Sub 入力候補表示(Sh As String, Rg As String, Tg As Range) 14 15 Dim foundCell As Variant 16 Dim listSheet As String '辞書のシート名 17 Dim strDictionary As String '辞書の範囲 18 Dim matchKey As String 19 Dim strFormula As String ' 入力規則に入れる文字列 20 Dim firstAddress As String ' 最初の結果のアドレス 21 Dim matchWord As String 22 Dim roopCount As Long 23 Dim lngY As Long, intX As Long 24 25 If Tg.Count > 1 Then Exit Sub 26 27 ' アクティブセルの値が辞書に載っているか検索 28 listSheet = Sh ' 検索対象シート 29 30 strDictionary = Rg ' 検索対象範囲 31 32 matchKey = Tg.Value 33 34 '部分一致で検索する(完全一致での検索を回避) 35 Set foundCell = Worksheets(listSheet).Range(strDictionary).Find( _ 36 What:=matchKey, LookAt:=xlPart) 37 38 ' 検索結果が空の場合終了 39 If foundCell Is Nothing Then Exit Sub 40 41 ' 検索結果を回す 42 43 strFormula = "" 44 roopCount = 0 45 firstAddress = foundCell.Address 46 Do 47 ' 辞書から入力候補を収集 48 lngY = foundCell.Cells.Row 49 intX = foundCell.Cells.Column 50 matchWord = Worksheets(listSheet).Cells(lngY, intX).Value 51 52 '比較 53 If InStr(matchWord, matchKey) > 0 Then 54 strFormula = strFormula & matchWord & "," 55 End If 56 57 roopCount = roopCount + 1 58 59 ' 次の入力候補へ 60 Set foundCell = Worksheets(listSheet).Range(strDictionary).FindNext(foundCell) 61 62 Loop While (Not foundCell Is Nothing) And (firstAddress <> foundCell.Address) 63 64 ' 入力候補をセット 65 Application.EnableEvents = False 66 67 68 If roopCount = 1 Then 69 '候補が一つの場合、それを入力 70 71 If Tg = "" Then 'エラー処理 72 Application.EnableEvents = True 73 strFormula = "" 74 Tg.Select 75 Exit Sub 76 Else 77 Tg.Value = Left(strFormula, Len(strFormula) - 1) 78 End If 79 80 ElseIf Len(strFormula) > 0 Then 81 82 83 'リストという名前の範囲を生成し配列を代入する 84 Application.ScreenUpdating = False 85 Call 入力規則リスト(strFormula, ActiveSheet) 86 Application.ScreenUpdating = True 87 '候補が複数ある場合は、候補のリストを表示 88 On Error GoTo ErrorHandler 89 With Tg.Validation '入力規則を設定 90 .Delete 91 .Add Type:=xlValidateList, Formula1:="=リスト" 92 .ShowError = False 93 .InCellDropdown = True 94 End With 95 Tg.Select 96 SendKeys "%{DOWN}" 97 End If 98 99 Set foundCell = Nothing 100 strFormula = "" 101 Application.EnableEvents = True 102 103ErrorHandler: 104 Application.EnableEvents = True 105 strFormula = "" 106End Sub
2.イベントを起こしたいシート(個人種目用シート)に下記のコードを記述
vba
1Private Sub Worksheet_Change(ByVal target As Range) 2 3 '辞書(住所の候補)を設定する:郵便番号データから候補表示 4 'DicSheetNameは辞書のシート名、 5 'DicRangeAddressは辞書の範囲を指定する 6 ' 7 Const DicSheetName = "Person" 8 Const DicRangeAddress = "A:A" 9 10 If target.Count > 1 Then 11 '選択セルが2つ以上は無効 12 Set target = Nothing 13 Exit Sub 14 15 ElseIf Application.Intersect(target, Range("AS4")) Is Nothing Then 16 '※入力セル以外の変更では無効(targetと共有するセル範囲がない) 17 Exit Sub 18 19 Else 20 '入力されたアドレスが住所入力のアドレスの場合に候補を表示 21 Call 入力候補表示(DicSheetName, DicRangeAddress, target) 22 End If 23 24End Sub
上記2つのコードは、下記のウェブサイトを参考にしました。
エクセルでグーグルサジェストっぽい入力をする
ファイルの構成
- 個人種目用シート
出場者氏名・新記録を出した種目等を入力するシートです。
出場者氏名はサジェスト機能を使用してAS4へ入力します。
新記録を出した種目を入力するセルは、AT4です。このAT4への入力をプルダウンリストから選択する方法にしたいのです。
このシートのA1:AQ63を記録証として印刷します。
0. リレー用シート
今回の問題には直接関係しません。
0. Personシート
出場者氏名、フリガナ、所属クラブ、出場種目等のデータベース的シートです。
出場者氏名はA列、出場種目はG列とJ列です。
G列のみ値がある(1種目だけ出場する)、G列とJ列両方とも値がある(2種目出場する)、G列とJ列両方とも値がない(競技役員として参加する)の3パターンがあります。
0. Teamシート
今回の問題には直接関係しません。
0. 配列格納
出場者氏名をサジェスト機能的な方法で入力するために、配列に格納した文字列を書き出すシートです。
名前をつけて入力規則で参照します。
上記の参考ウェブサイトの「リスト用シート」に該当します。
以上
あなたの回答
tips
プレビュー