MENU

Category カテゴリカテゴリ

PC/Gadget パソコン・ガジェット
Soft/App ソフト・アプリ
Entertainment エンタメ・イベント
Shopping お買い物
D.I.Y. セルフリフォーム
Download ダウンロード

パソコン関連のお得情報

マイクロソフトオフィス
マッキントッシュ
ウインドウズ
Adobe イラストレーター
ワードプレス
Apple iPhone
iPad & Apple Pencil
アプリ

©Goblog ごぶろぐ
created by N/A | powerd by SWELL

ソフトやガジェットのPR記事依頼はお気軽にお問い合わせください

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

MicrosoftofficeExcelでサジェスト変換機能を実装するマクロ

悩む人

Excelを使って仕事をしているけど、大量のリストの中から予測変換をしたい…できるのかな?

サジェスト機能とは、Google検索などの検索窓で検索する際に、入力途中の文章から予測表示することをいいます。

この記事では、Excelでも「サジェスト機能」を使えるようにマクロをご紹介します。

目次

参考記事の紹介:主に言語とシステム開発に関して・ググル × blog

ごん

今回紹介するサジェスト機能は、「主に言語とシステム開発に関して」と、それを元に書かれた「ググル × blog」の記事で紹介されているものです。

記一部エラーになってマクロが動かないことと、もう少し細かくマクロの登録方法をご紹介させていただきます。

あくまで、コードは
language_and_engineeringさん
shimanefuraiboさん
Santa Networkさんが
作ってくださったものとなります

※2021.12.8
ナムロックがオフになるエラーを修正しました

Excelでサジェスト機能を実施する

ごん

それでは 「ググル × blog」 のblogで紹介されているExcelのサジェスト機能の実施方法について、説明します

ややこしいので、他にExcelのブックを同時で開かないようにしましょう。

STEP
マクロ有効ブックを作成する

まず、Excelを新規作成し、マクロ有効ブックで保存します。

STEP
EXCELのシートを作る

Excelのシートを

・リスト用
・辞書

の名前で追加してください。
入力シートの名前はなんでも構いません。

STEP
VBAを起動する

EXCELのシート名のタブ(どのタブでもOK)で右クリックし、コードの表示を選択

STEP
標準モジュールを挿入する

メニューバーの挿入から、標準モジュールを選択します

STEP
追加された標準モジュールに入力する

追加されたModule1をダブルクリックし、下記コードをコピペします

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

貼り付け後のイメージはこんなかんじです

STEP
サジェスト機能を実施するシートにコードを貼り付ける

実際にサジェスト機能を使いたいシートに書きコードをコピペします。
私の場合は、「入力」とシート名を付けていますので、Sheet1(入力)に貼り付けます。

Private Sub Worksheet_Change(ByVal target As Range)
   
    '辞書(住所の候補)を設定する:郵便番号データから候補表示
    'DicSheetNameは辞書のシート名、
    'DicRangeAddressは辞書の範囲を指定する
    '
    Const DicSheetName = "辞書"
    Const DicRangeAddress = "A:A"

     If target.Count > 1 Then
     '選択セルが2つ以上は無効
         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

貼り付け後のイメージはこんなかんじです

サジェストの適用範囲を変更する場合は、

ElseIf Application.Intersect(target, Range(“A:A”)) Is Nothing Then

の中の “A:A” を変更してください

STEP
完成

上書き保存して完成です。
あとは入力用のシートのサジェスト適用範囲で、入力途中の状態でエンターを押し、Alt+を押せばサジェストが適用されます

管理人:ごん(デザイナー)

管理人:ごん(デザイナー)

「時短・楽したい」がモットー!Twitterでも情報公開しています
記事のライティング依頼やPR記事依頼・広告掲載のご依頼も受付中

よかったらシェアしてね!
  • URLをコピーしました!
目次