Excel VBA 逆引き集 | Trie構造

Excel VBA
スポンサーリンク

ねらい：VBAでTrie（トライ）を実装し、前方一致検索やオートコンプリートを高速化する

Trieは文字列の「共有された接頭辞」を一度だけ保持する木構造です。Excelでの大量ワード検索、商品コードの前方一致、オートコンプリート、NGワード判定などで、線形検索より桁違いに速くなります。初心者でも貼って動かせるよう、クラステンプレート（CTrie／CTrieNode）と、シート連携・検索UI・削除・永続化まで丁寧に解説します。

重要ポイントの深掘り

  • 構造: 各ノードは「文字→次ノード」の辞書と「語の終端フラグ」を持ちます。
  • 速度: 前方一致はキー長に比例し、登録語数にほぼ依存しません。大量語でも安定します。
  • 実装方針: VBAでは Scripting.Dictionary を使い、Late Binding（CreateObject）で参照設定なしに動かします。
  • 正規化: 大文字小文字・全半角・トリムを統一してから登録すると、検索のズレが起きません。

Trieの考え方と利点

Trieが得意なこと

  • 前方一致検索: 「pre」で始まる語を高速列挙。
  • オートコンプリート: 入力中プレフィックスから候補提示。
  • 存在判定: 完全一致の語があるか即判定。
  • 頻度や付加情報: 終端ノードに「回数やID」を付けると検索後の処理が楽。

他構造との比較

  • 配列＋InStr: 簡単だが全件走査で遅い。
  • Dictionary（キー集合）： 完全一致は速いが前方一致は苦手。
  • Trie: 完全一致も前方一致も強い。構築コストがあるが検索は語長依存で安定。

基本実装（貼って動く）：CTrieNode と CTrie

CTrieNode（クラスモジュール：CTrieNode）

' CTrieNode.cls
Option Explicit

Private mChildren As Object ' Scripting.Dictionary: Key=String(char), Value=CTrieNode
Private mIsEnd As Boolean
Private mValue As Variant ' 終端に付ける任意情報（IDや頻度など）

Private Sub Class_Initialize()
    Set mChildren = CreateObject("Scripting.Dictionary")
    mIsEnd = False
    mValue = Empty
End Sub

Public Property Get Children() As Object
    Set Children = mChildren
End Property

Public Property Get IsEnd() As Boolean
    IsEnd = mIsEnd
End Property
Public Property Let IsEnd(ByVal v As Boolean)
    mIsEnd = v
End Property

Public Property Get Value() As Variant
    Value = mValue
End Property
Public Property Let Value(ByVal v As Variant)
    mValue = v
End Property

Public Function EnsureChild(ByVal ch As String) As CTrieNode
    If Not mChildren.Exists(ch) Then
        Dim node As New CTrieNode
        mChildren.Add ch, node
    End If
    Set EnsureChild = mChildren(ch)
End Function

Public Function GetChild(ByVal ch As String) As CTrieNode
    If mChildren.Exists(ch) Then Set GetChild = mChildren(ch)
End Function
VB

CTrie（クラスモジュール：CTrie）

' CTrie.cls
Option Explicit

Private mRoot As CTrieNode
Private mCount As Long
Private mCaseSensitive As Boolean

Private Sub Class_Initialize()
    Set mRoot = New CTrieNode
    mCount = 0
    mCaseSensitive = False ' 既定は大小同一視
End Sub

Public Property Get Count() As Long
    Count = mCount
End Property

Public Property Get CaseSensitive() As Boolean
    CaseSensitive = mCaseSensitive
End Property
Public Property Let CaseSensitive(ByVal v As Boolean)
    mCaseSensitive = v
End Property

Private Function Normalize(ByVal s As String) As String
    Dim t As String: t = Trim$(s)
    If Not mCaseSensitive Then t = LCase$(t)
    Normalize = t
End Function

Public Sub Insert(ByVal s As String, Optional ByVal info As Variant)
    Dim str As String: str = Normalize(s)
    If Len(str) = 0 Then Exit Sub

    Dim node As CTrieNode: Set node = mRoot
    Dim i As Long
    For i = 1 To Len(str)
        Set node = node.EnsureChild(Mid$(str, i, 1))
    Next
    If Not node.IsEnd Then mCount = mCount + 1
    node.IsEnd = True
    If Not IsEmpty(info) Then node.Value = info
End Sub

Public Function Contains(ByVal s As String) As Boolean
    Dim node As CTrieNode: Set node = WalkToNode(Normalize(s))
    Contains = Not node Is Nothing And node.IsEnd
End Function

Public Function StartsWith(ByVal prefix As String) As Boolean
    StartsWith = Not WalkToNode(Normalize(prefix)) Is Nothing
End Function

Public Function CollectByPrefix(ByVal prefix As String, Optional ByVal limit As Long = 0) As Variant
    Dim base As String: base = Normalize(prefix)
    Dim node As CTrieNode: Set node = WalkToNode(base)
    If node Is Nothing Then Exit Function

    Dim results() As String: ReDim results(1 To IIf(limit > 0, limit, 1000))
    Dim count As Long: count = 0
    DFSCollect node, base, results, count, limit
    If count = 0 Then Exit Function

    Dim out() As String: ReDim out(1 To count)
    Dim i As Long: For i = 1 To count: out(i) = results(i): Next
    CollectByPrefix = out
End Function

Private Function WalkToNode(ByVal s As String) As CTrieNode
    Dim node As CTrieNode: Set node = mRoot
    Dim i As Long
    For i = 1 To Len(s)
        Dim ch As String: ch = Mid$(s, i, 1)
        Set node = node.GetChild(ch)
        If node Is Nothing Then Exit For
    Next
    Set WalkToNode = node
End Function

Private Sub DFSCollect(ByVal node As CTrieNode, ByVal path As String, _
                       ByRef results() As String, ByRef count As Long, ByVal limit As Long)
    If node.IsEnd Then
        count = count + 1
        If count > UBound(results) Then ReDim Preserve results(1 To count + 1000)
        results(count) = path
        If limit > 0 And count >= limit Then Exit Sub
    End If

    Dim k As Variant
    For Each k In node.Children.Keys
        If limit > 0 And count >= limit Then Exit For
        Dim child As CTrieNode: Set child = node.Children(k)
        Call DFSCollect(child, path & CStr(k), results, count, limit)
    Next
End Sub

Public Function Delete(ByVal s As String) As Boolean
    Dim stackNodes() As CTrieNode, stackChars() As String, depth As Long
    Dim str As String: str = Normalize(s)
    If Len(str) = 0 Then Exit Function

    ReDim stackNodes(1 To Len(str)), stackChars(1 To Len(str))

    Dim node As CTrieNode: Set node = mRoot
    Dim i As Long
    For i = 1 To Len(str)
        Dim ch As String: ch = Mid$(str, i, 1)
        Set node = node.GetChild(ch)
        If node Is Nothing Then Exit Function
        depth = depth + 1
        Set stackNodes(depth) = node
        stackChars(depth) = ch
    Next

    If Not node.IsEnd Then Exit Function
    node.IsEnd = False
    mCount = mCount - 1

    ' 後ろから「子がゼロ＆終端でない」ノードを削除
    Dim d As Long
    For d = depth To 1 Step -1
        Dim parent As CTrieNode
        If d = 1 Then Set parent = mRoot Else Set parent = stackNodes(d - 1)
        Dim cur As CTrieNode: Set cur = stackNodes(d)
        If cur.Children.Count = 0 And Not cur.IsEnd Then
            parent.Children.Remove stackChars(d)
        Else
            Exit For
        End If
    Next
    Delete = True
End Function
VB

例題：シートの語彙をTrieに登録し、前方一致で候補を返す

語彙読み込みと検索の入口（標準モジュール）

' ModTrieDemo.bas
Option Explicit

Private gTrie As CTrie

Public Sub BuildTrieFromSheet()
    Dim ws As Worksheet: Set ws = Worksheets("Words") ' A列に語彙
    Dim last As Long: last = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set gTrie = New CTrie
    gTrie.CaseSensitive = False

    Dim r As Long
    For r = 2 To last
        Dim s As String: s = Trim$(CStr(ws.Cells(r, "A").Value))
        If Len(s) > 0 Then gTrie.Insert s
    Next
    MsgBox "登録件数: " & gTrie.Count, vbInformation
End Sub

Public Sub SearchPrefix()
    If gTrie Is Nothing Then BuildTrieFromSheet
    Dim prefix As String: prefix = InputBox("前方一致のプレフィックスを入力", "Trie Search", "pre")
    If Len(prefix) = 0 Then Exit Sub
    Dim arr As Variant: arr = gTrie.CollectByPrefix(prefix, 50)
    If IsEmpty(arr) Then
        MsgBox "該当なし", vbInformation
        Exit Sub
    End If

    ' 結果をResultsシートに出力
    Dim ws As Worksheet: Set ws = PrepareOutputSheet("Results")
    ws.Range("A1").Value = "Prefix: " & prefix
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        ws.Cells(i + 1, "A").Value = arr(i)
    Next
    ws.Columns.AutoFit
End Sub

Private Function PrepareOutputSheet(ByVal name As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = name
    End If
    ws.Cells.Clear
    Set PrepareOutputSheet = ws
End Function
VB

重要ポイントの深掘り

  • チャンク化不要: 検索は語長依存なので瞬間。登録は数万語でも数秒～数十秒程度。
  • 結果制限: CollectByPrefix(limit)で最大件数を制限し、UIを守る。
  • 正規化: CaseSensitiveを切り替えるだけで大小同一視に対応。

応用テンプレ：オートコンプリート・NGワード判定・付加情報

オートコンプリート（先頭候補だけ返す）

Public Function AutoCompleteTop(ByVal prefix As String) As String
    If gTrie Is Nothing Then Exit Function
    Dim arr As Variant: arr = gTrie.CollectByPrefix(prefix, 1)
    If Not IsEmpty(arr) Then AutoCompleteTop = arr(1)
End Function
VB

NGワード判定（完全一致）

Public Function IsNgWord(ByVal s As String) As Boolean
    If gTrie Is Nothing Then Exit Function
    IsNgWord = gTrie.Contains(s)
End Function
VB

付加情報（終端にIDや頻度を持たせる例）

' 登録時にinfoを渡す
' gTrie.Insert "apple", 1234 ' 商品ID
' 検索関数の拡張（例：CollectByPrefixでValueも別配列に貯める）—必要ならCTrieに追記
VB

重要ポイントの深掘り

  • 完全一致と前方一致の使い分け: フィルタや判定は Contains、候補提示は CollectByPrefix。
  • Value活用: 終端ノードのValueで外部キー（ID）や頻度を保持すると、検索後の照合が一発です。

削除・更新・永続化の実務設計

削除・更新

  • 削除: Deleteで終端フラグを外し、不要ノードを後ろから掃除。
  • 更新: 旧語をDelete→新語をInsert。語彙表の変更を逐次反映します。

永続化（CSVで保存→再構築）

' 保存：WordsシートをCSVで保存（既存機能でOK）
' 復元：起動時にCSVを読み、行ごとに Insert
Public Sub LoadFromCsv(ByVal path As String)
    Dim st As Object: Set st = CreateObject("ADODB.Stream")
    st.Type = 2: st.Charset = "UTF-8": st.Open: st.LoadFromFile path
    Dim lines() As String: lines = Split(st.ReadText, vbCrLf): st.Close
    Set gTrie = New CTrie
    Dim i As Long
    For i = 0 To UBound(lines)
        Dim s As String: s = Trim$(lines(i))
        If Len(s) > 0 Then gTrie.Insert s
    Next
End Sub
VB

重要ポイントの深掘り

  • 再構築の速さ: Trieは構築コストがあるため、起動時に一度だけロードして使い回すのが基本。
  • 文字コード: CSVはUTF-8固定にして、文字化けを防ぎます。

パフォーマンス・メモリ・安全運用のコツ

前処理と正規化

  • 必須: Trim、大小同一視（LCase）、不要記号除去で揺らぎを減らす。
  • 日本語: 全角半角統一が必要なら、置換テーブルを前処理で適用。

メモリと件数の目安

  • 目安: ASCII系なら数万～十数万語で実用。数百万語はVBA単体では厳しく、外部連携（PowerShellやSQLite）推奨。
  • Valueの使い方: 大きすぎるオブジェクトを持たせるとメモリを食うため、IDだけにして別表で参照するのが賢い。

再帰の安全性

  • Collect: DFSは再帰。語長が極端に長いとスタックが深くなるが、一般的な語彙では問題になりにくい。深さが不安ならスタック（Collection）で非再帰のDFS/BFSに差し替え可。

まとめ：Trieは「前方一致・候補提示」の切り札。VBAでも十分実用になる

  • CTrie／CTrieNodeで最小実装、Scripting.Dictionaryで速い分岐。
  • 語彙を一度構築し、Contains／CollectByPrefixで即検索。
  • Excelシートと繋げば、商品リスト・コード表・辞書などで快適な検索UXが作れる。
  • 正規化・件数制限・永続化を揃えれば、現場でも安定運用できます。

スポンサーリンク
タイトルとURLをコピーしました