テキストファイルの重複しない単語の数

質問

単語ごとに半角スペースで区切られる外国語（英語・ドイツ語など）のテキストファイルに含まれる単語の種類の総数を知るにはどうしたらよいでしょうか。

いま１０のテキストファイルがあり、それぞれ数千語の単語が含まれています。

私が知りたい単語の種類の総数というのは、重複しない単語の数のことです。
is が１０回出てきても、１単語と数える感じです。

回答No.1

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

Excel VBA での回答です。別に VBS でも良かったのですが...OFFICE カテなので、
結構難しいですよねー。例えば I've とかをどう切り分けるか？

考えたけど、英語は良く分からないのでそのまんま半角スペースで区切りました。
あと工夫したのは、記号をカットするとこですかね...(´・ω・`)

あまりに巨大なテキストファイルだと時間がかかるか、フリーズするかもしれま
せんが、通常サイズのテキストファイルなら VBA でも結構高速で集計できますよ。

【実行手順】
1.　Excel を起動
2.　[Alt]+[F11]キー押下で Visual Basic Editor（以下 VBE）を起動
3.　VBE メニュー[挿入]-[標準モジュール]
4.　3. で開いたスペースに下記の Sub から始まるコードをコピー＆ペースト
5.　VBE 閉じる
6.　Excel 画面に戻り、[Alt]+[F8] でマクロ実行
7.　あとは適当に画面のとおり。

' コードはここから下

Sub 重複しない単語の数を調べる()

　　Dim Dic　　　 As Object 'Dictionary
　　Dim sFilename As String
　　Dim n　　　　 As Integer
　　Dim sBuf　　　As String
　　Dim vKeysAry　As Variant
　　Dim vKey　　　As Variant
　　Dim vCnt　　　As Variant
　　Dim lKeyCount As Long

　　Const NONCOUNT_KEY = "!""#$%&()^\`[+*]{}<>?,./_:;" ' 除外する記号

　　' 対象テキストファイル問い合わせ
　　sFilename = Application.GetOpenFilename( _
　　　　　　　　FileFilter:="Textファイル (*.txt),*.txt", _
　　　　　　　　Title:="重複しない単語の数を調べます ※シートはクリアされます", _
　　　　　　　　MultiSelect:=False)
　　If UCase$(sFilename) = "FALSE" Then Exit Sub
　　' テキストデータを読み込む
　　n = FreeFile()
　　Open sFilename For Binary Access Read As #n
　　　　sBuf = String$(LOF(n), vbNullChar)
　　　　Get #n, , sBuf
　　Close #n
　　sBuf = Replace$(sBuf, vbNullChar, "")
　　' テキストデータ前加工
　　sBuf = StrConv(sBuf, vbNarrow)
　　sBuf = Replace$(sBuf, vbCrLf, vbLf)
　　sBuf = Replace$(sBuf, vbCr, vbLf)
　　sBuf = Replace$(sBuf, vbLf, " ")
　　' 除外する記号を半角SPへ置換
　　For n = 1 To Len(NONCOUNT_KEY)
　　　　sBuf = Replace(sBuf, Mid$(NONCOUNT_KEY, n, 1), " ")
　　Next n
　　' テキストデータを半角SPで分解して配列化
　　vKeysAry = Split(sBuf, " ")
　　' 語句をカウント
　　Set Dic = CreateObject("Scripting.Dictionary")
　　Dic.CompareMode = 1 ' 1: TextCompare 大文字・小文字を区別しない
　　For Each vKey In vKeysAry
　　　　If Len(vKey) > 0 Then
　　　　　　If Not Dic.Exists(vKey) Then
　　　　　　　　Dic.Add Key:=vKey, Item:=CStr(1)
　　　　　　Else
　　　　　　　　Dic(vKey) = CStr(Val(Dic(vKey)) + 1)
　　　　　　End If
　　　　End If
　　Next
　　' 結果出力
　　vKey = Application.Transpose(Dic.Keys)
　　vCnt = Application.Transpose(Dic.Items)
　　With ActiveSheet
　　　　.Cells.Clear
　　　　.Cells(1, 1).Value = sFilename
　　　　.Cells(3, 1).Value = "Word"
　　　　.Cells(3, 2).Value = "Count"
　　　　With Range(.Cells(3, 1), .Cells(3, 2))
　　　　　　.Font.Bold = True
　　　　　　.HorizontalAlignment = xlCenter
　　　　End With
　　　　lKeyCount = UBound(vKey)
　　　　If lKeyCount > Rows.Count Then lKeyCount = Rows.Count
　　　　.Cells(4, 1).Resize(lKeyCount).Value = vKey
　　　　.Cells(4, 2).Resize(lKeyCount).Value = vCnt
　　End With
　　Set Dic = Nothing
　　MsgBox "終わったみたい(´・ω・`)", vbInformation

End Sub

お礼

試してみました。
すごいスクリプトです。感動しました。

英語で試したところtheの頻度が一番多かったです。