VBAでBM25アルゴリズムを実装したコードです：
' BM25検索アルゴリズム実装（VBA版）
Option Explicit
' BM25のパラメータ
Private Const k1 As Double = 1.5
Private Const b As Double = 0.75
' ドキュメント情報を格納する型
Private Type DocInfo
Terms() As String ' 分かち書きされた単語
TermFreq As Object ' 単語の出現頻度（Dictionary）
DocLength As Long ' ドキュメントの長さ（単語数）
End Type
' 検索エンジンクラス
Private Type BM25Engine
Documents() As DocInfo ' ドキュメント配列
AvgDocLength As Double ' 平均ドキュメント長
DocCount As Long ' ドキュメント数
Vocabulary As Object ' 語彙（全単語のDictionary）
IDF As Object ' 逆文書頻度（Dictionary）
IsInitialized As Boolean ' 初期化済みフラグ
End Type
' エンジンのグローバルインスタンス
Private Engine As BM25Engine
' エンジンを初期化する
Public Sub InitializeBM25Engine()
' 辞書オブジェクトの作成
Set Engine.Vocabulary = CreateObject("Scripting.Dictionary")
Set Engine.IDF = CreateObject("Scripting.Dictionary")
Engine.DocCount = 0
Engine.AvgDocLength = 0
Engine.IsInitialized = True
End Sub
' ドキュメントを追加する
Public Sub AddDocument(docText As String, docID As Long)
If Not Engine.IsInitialized Then
InitializeBM25Engine
End If
' ドキュメント数を増やす
Engine.DocCount = Engine.DocCount + 1
' 必要に応じて配列をリサイズ
ReDim Preserve Engine.Documents(1 To Engine.DocCount)
' テキストを単語に分割
Dim terms() As String
terms = SplitTextIntoTerms(docText)
' 単語の頻度辞書を作成
Dim termFreq As Object
Set termFreq = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = LBound(terms) To UBound(terms)
' 単語頻度を更新
If termFreq.Exists(terms(i)) Then
termFreq(terms(i)) = termFreq(terms(i)) + 1
Else
termFreq.Add terms(i), 1
End If
' 全体語彙に追加
If Not Engine.Vocabulary.Exists(terms(i)) Then
Engine.Vocabulary.Add terms(i), 1
End If
Next i
' ドキュメント情報を格納
With Engine.Documents(Engine.DocCount)
.Terms = terms
Set .TermFreq = termFreq
.DocLength = UBound(terms) - LBound(terms) + 1
End With
' 平均ドキュメント長を更新
Dim totalLength As Long
For i = 1 To Engine.DocCount
totalLength = totalLength + Engine.Documents(i).DocLength
Next i
Engine.AvgDocLength = totalLength / Engine.DocCount
' IDFを計算
CalculateIDF
End Sub
' 単語ごとのIDFを計算
Private Sub CalculateIDF()
Set Engine.IDF = CreateObject("Scripting.Dictionary")
Dim term As Variant
For Each term In Engine.Vocabulary.Keys
' この単語を含むドキュメント数をカウント
Dim docFreq As Long
docFreq = 0
Dim i As Long
For i = 1 To Engine.DocCount
If Engine.Documents(i).TermFreq.Exists(term) Then
docFreq = docFreq + 1
End If
Next i
' IDF計算: log((N-n+0.5)/(n+0.5) + 1)
Dim idfValue As Double
idfValue = Log10((Engine.DocCount - docFreq + 0.5) / (docFreq + 0.5) + 1)
' 負の値は0にする（まれなケース）
If idfValue < 0 Then idfValue = 0
' IDFを保存
If Engine.IDF.Exists(term) Then
Engine.IDF(term) = idfValue
Else
Engine.IDF.Add term, idfValue
End If
Next term
End Sub
' 検索を実行し、ドキュメントのランキングを返す
Public Function Search(query As String) As Variant
If Not Engine.IsInitialized Or Engine.DocCount = 0 Then
MsgBox "検索エンジンが初期化されていないか、ドキュメントがありません"
Exit Function
End If
' クエリを単語に分割
Dim queryTerms() As String
queryTerms = SplitTextIntoTerms(query)
' 各ドキュメントのスコアを計算
Dim scores() As Double
ReDim scores(1 To Engine.DocCount)
Dim i As Long, j As Long
Dim term As String
For j = LBound(queryTerms) To UBound(queryTerms)
term = queryTerms(j)
' クエリ内の単語が語彙にある場合のみ処理
If Engine.Vocabulary.Exists(term) Then
For i = 1 To Engine.DocCount
Dim doc As DocInfo
doc = Engine.Documents(i)
' 単語がドキュメントに存在する場合のみスコアを計算
If doc.TermFreq.Exists(term) Then
Dim tf As Long
tf = doc.TermFreq(term)
' BM25スコア計算
Dim idf As Double
idf = Engine.IDF(term)
Dim numerator As Double
numerator = tf * (k1 + 1)
Dim denominator As Double
denominator = tf + k1 * (1 - b + b * doc.DocLength / Engine.AvgDocLength)
Dim termScore As Double
termScore = idf * numerator / denominator
' ドキュメントのスコアに加算
scores(i) = scores(i) + termScore
End If
Next i
End If
Next j
' ランク付けされた結果を返す（スコアと文書ID）
Dim results() As Variant
ReDim results(1 To Engine.DocCount, 1 To 2)
For i = 1 To Engine.DocCount
results(i, 1) = i ' ドキュメントID
results(i, 2) = scores(i) ' スコア
Next i
' スコアでソート（簡易版バブルソート）
Dim temp(1 To 2) As Variant
For i = 1 To Engine.DocCount - 1
For j = i + 1 To Engine.DocCount
If results(i, 2) < results(j, 2) Then
' スワップ
temp(1) = results(i, 1)
temp(2) = results(i, 2)
results(i, 1) = results(j, 1)
results(i, 2) = results(j, 2)
results(j, 1) = temp(1)
results(j, 2) = temp(2)
End If
Next j
Next i
Search = results
End Function
' テキストを単語に分割（簡易的な実装）
Private Function SplitTextIntoTerms(text As String) As String()
' 大文字を小文字に変換
text = LCase(text)
' 記号を空白に置換
text = Replace(text, ".", " ")
text = Replace(text, ",", " ")
text = Replace(text, ";", " ")
text = Replace(text, ":", " ")
text = Replace(text, "!", " ")
text = Replace(text, "?", " ")
text = Replace(text, "(", " ")
text = Replace(text, ")", " ")
text = Replace(text, "[", " ")
text = Replace(text, "]", " ")
text = Replace(text, "{", " ")
text = Replace(text, "}", " ")
text = Replace(text, """", " ")
text = Replace(text, "'", " ")
text = Replace(text, "-", " ")
text = Replace(text, "_", " ")
' 連続する空白を単一の空白に変換
Do While InStr(text, " ") > 0
text = Replace(text, " ", " ")
Loop
' 先頭と末尾の空白を削除
text = Trim(text)
' 分割して返す
SplitTextIntoTerms = Split(text, " ")
End Function
' 対数関数（VBAにはLog10がないため）
Private Function Log10(x As Double) As Double
Log10 = Log(x) / Log(10#)
End Function
' 使用例
Public Sub TestBM25()
' エンジンを初期化
InitializeBM25Engine
' ドキュメントを追加
AddDocument "Excelは表計算ソフトウェアです。", 1
AddDocument "VBAはマクロプログラミング言語です。", 2
AddDocument "ExcelでVBAを使うと業務を自動化できます。", 3
AddDocument "ビジネスアプリケーションの開発にはVBAが便利です。", 4
' 検索を実行
Dim results As Variant
results = Search("VBA Excel 自動化")
' 結果を表示
Dim i As Long
For i = 1 To UBound(results, 1)
Debug.Print "ドキュメントID: " & results(i, 1) & ", スコア: " & results(i, 2)
Next i
End Sub
使用方法：
- Excel VBAエディタを開きます（Alt + F11）
- 新しいモジュールを挿入します（挿入 > モジュール）
- 上記のコードを貼り付けます
-
TestBM25サブルーチンを実行して動作確認ができます
実際の活用例：
Public Sub 雪だるま開発ツール用BM25検索()
' エンジンを初期化
InitializeBM25Engine
' ドキュメントのロード（ここではセルからデータを取得する例）
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("ナレッジベース")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 2 To lastRow ' A列に格納されているドキュメントをロード
AddDocument ws.Cells(i, "A").Value, i - 1
Next i
' ユーザー入力で検索
Dim query As String
query = InputBox("検索キーワードを入力してください：", "雪だるま開発ツール検索")
If query = "" Then Exit Sub
' 検索実行
Dim results As Variant
results = Search(query)
' 結果をシートに出力
Dim outputWs As Worksheet
Set outputWs = ThisWorkbook.Worksheets("検索結果")
' 結果をクリア
outputWs.Range("A1:C1000").ClearContents
' ヘッダー設定
outputWs.Range("A1").Value = "ドキュメントID"
outputWs.Range("B1").Value = "スコア"
outputWs.Range("C1").Value = "内容"
' 結果出力
For i = 1 To UBound(results, 1)
If results(i, 2) > 0 Then ' スコアが0より大きい場合のみ表示
outputWs.Cells(i + 1, "A").Value = results(i, 1)
outputWs.Cells(i + 1, "B").Value = results(i, 2)
outputWs.Cells(i + 1, "C").Value = ws.Cells(results(i, 1) + 1, "A").Value
End If
Next i
End Sub
このVBA実装は、セキュリティ制約のある環境でも安全に使用できる軽量な代替アルゴリズムです。日本語テキストの場合は、分かち書き（単語分割）処理をより洗練されたものに置き換えることで精度を向上させることができます。