🖥️

Excel VBA でサジェスト機能付きメール入力フォームを作る

に公開
Excel
VBA
Excel
サジェスト
tech

Excel で「メールアドレスを入力するセルがたくさんあって面倒だな…」と思ったことはありませんか？
特に同じアドレス帳を何度も参照する場合、いちいちコピペやドロップダウンで探すのは非効率です。

この記事では Excel VBA を使ってサジェスト（候補補完）機能付きのメール入力フォーム を作る方法を紹介します。
しかも、メールアドレスは前方一致、名前は部分一致 で検索できるように拡張しています。

完成イメージ

  1. 「メール」シートの B2:K4 に入力すると…
  2. ユーザーフォームがポップアップし、候補のメールアドレスをリアルタイムに表示
  3. メールアドレスは A列から、名前は B列から検索
  4. 候補を選ぶとセルに反映！

これでメールアドレス入力のストレスが激減します。

構成

  • メールシート（入力用）
  • アドレス帳シート（A列=メールアドレス, B列=名前）
  • UserForm1（ListBox1 と CommandButton1 を配置）


コード全体

メールシート（入力監視）

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Me.Range("B2:K4")) Is Nothing Then Exit Sub

    If Len(Trim(Target.Value)) = 0 Then Exit Sub

    ' 入力キーワードとセルアドレスを渡す
    On Error Resume Next
    UserForm1.ShowCandidates CStr(Target.Value), Target.Address
    On Error GoTo 0
End Sub

UserForm1（候補表示と選択）

Option Explicit

Public Sub ShowCandidates(ByVal keyword As String, ByVal targetAddress As String)
    Dim wsAddr As Worksheet
    Dim rng As Range, cell As Range
    Dim k As String
    Dim dict As Object
    Dim email As String, nameStr As String
    Dim itm As Variant

    k = Trim(LCase(keyword))
    Me.ListBox1.Clear
    Me.Tag = targetAddress

    If Len(k) = 0 Then Exit Sub

    Set dict = CreateObject("Scripting.Dictionary")
    Set wsAddr = ThisWorkbook.Sheets("アドレス帳")
    Set rng = wsAddr.Range("A2", wsAddr.Cells(wsAddr.Rows.Count, "A").End(xlUp))

    For Each cell In rng
        If Len(cell.Value) = 0 Then GoTo NextRow
        email = CStr(cell.Value)
        nameStr = CStr(cell.Offset(0, 1).Value)

        ' メールアドレス: 前方一致
        If LCase(email) Like k & "*" Then
            If Not dict.Exists(email) Then dict.Add email, email
        End If

        ' 名前: 部分一致
        If Len(nameStr) > 0 Then
            If InStr(1, nameStr, keyword, vbTextCompare) > 0 Then
                If Not dict.Exists(email) Then dict.Add email, email
            End If
        End If
NextRow:
    Next cell

    If dict.Count = 0 Then
        Unload Me
        Exit Sub
    End If

    For Each itm In dict.Items
        Me.ListBox1.AddItem itm
    Next itm

    If Me.ListBox1.ListCount > 0 Then Me.ListBox1.ListIndex = 0
    Me.Show vbModeless
End Sub

' 候補選択でセルに反映
Public Sub ApplySelection()
    If Me.ListBox1.ListIndex >= 0 Then
        Dim tgt As Range
        Set tgt = ThisWorkbook.Sheets("メール").Range(Me.Tag)
        Application.EnableEvents = False
        tgt.Value = Me.ListBox1.Value
        Application.EnableEvents = True
    End If
    Unload Me
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    ApplySelection
End Sub

Private Sub CommandButton1_Click()
    ApplySelection
End Sub

ポイント解説

  • Worksheet_Change でセル入力を監視し、フォーム呼び出し
  • メールアドレスは前方一致（例: ab → abc@example.com）
  • 名前は部分一致（例: 田中 → tanaka@example.com）
  • Scripting.Dictionary を使って重複を排除
  • UserForm は vbModeless 表示 なので操作しやすい

応用アイデア

  • ListBox に「名前 + メールアドレス」を表示して、選択するとメールアドレスだけセルに反映
  • 候補が1件しかないときは自動確定
  • 入力範囲を拡張して、部署別のサジェストにも対応

まとめ

Excel の標準機能だけでは「使いやすい入力補助」はなかなか実現できません。
しかし VBA を少し工夫するだけで、まるで Gmail の入力補完のような体験を Excel 上に作れます。

「定型的な入力で時間を取られている」方は、ぜひ試してみてください！ 🚀

Discussion