言語ごとに頻出度の高い単語が必ず存在する。
それぞれの言語でよく出てくる単語を手軽に調べれないかな～？
と思ったのでVBAプログラムを作ってみました。
そもそもVBAって何？
以下を読んで、どうぞ
VBAの動作概要
プログラムの動きを５行で説明すると以下。
１．外国語の文章が入ったテキストファイルを読み込む
２．テキストから単語へ区切る
３．同じ単語が出てきたらカウントする
４．３．のカウント数が多い単語の順に並べる（ソート）
５．４．の順番に上から並べて書き込む
本記事で用いた外国語の文章
使った文章は「日本」のウィキペディア記事。
私は多言語のテキストが欲しかったので「ポーランド語版」のウィキペディアを使った。
他の言語版だと，他の言語一覧が圧縮されてしまう。
だけどポーランド語版の場合は，他の言語一覧が圧縮されない。
全部ずら～っと表示される。
なので・・・
・どんな言語版があるのか一目で分かる
・これ何語？ってなった時にコピペできる
１００言語の上位２０位の単語リスト
各言語で書かれているテキストをVBAに読み込ませて、頻出度の高い単語の順番に書きこませた。
たまに変な単語が混ざっているのは仕様です。
アイスランド語
アイルランド語
アゼルバイジャン語
アブハズ語
アフリカーンス語
アラゴン語
アラビア語
アルメニア語
アレマン語
イタリア語
イディッシュ語
イド
ヴェネト語
ヴェプス語
ウクライナ語
ウルドゥー語
古英語
英語
エストニア語
エスペラント
オランダ語
カザフ語
カシューブ語
カタルーニャ語
ガリジア語
カルムイク語
韓国語
広東語
カンナダ語
現代ギリシャ語
グジャラート語
グルジア語（ジョージア語）
クルド語
クロアチア語
低ザクセン語
ザザキ語
サモギティア語
シレジア語
シンハラ語
スウェーデン語
スコットランド・ゲール語
スコットランド語
スペイン語
スロベニア語
スワヒリ語
スンダ語
ゼーランド語
セルビア語
ソマリア語
タイ語
タガログ語
タタール語
タミル語
チェコ語
中国語（普通話）
ツォンガ語
テルグ語
デンマーク語
低地ドイツ語
ドイツ語
トゥバ語
トゥル語
トルクメン語
トルコ語
ノヴィアル
ノルウェー語（ニーノシュク）
ノルウェー語（ブークモール）
バシキール語
ハワイ語
ハンガリー語
バンジャル語
ヒンディー語
閩南（びんなん）語
フィンランド語
フェロー語
フランス語
西フリジア語
ブリヤート語
ブルガリア語
ベトナム語
ヘブライ語
ベラルーシ語
ペルシア語
ベンガル語
ポーランド語
ボスニア語
ポルトガル語
マケドニア語
マダガスカル語
マラヤーラム語
マルタ語
モンゴル語
ヨルバ語
ラテン語
リトアニア語
リングア・フランカ・ノバ
ルシン語
ロシア語
ロジバン
ワライ語
VBAのソースコード
Option Explicit ‘このモジュールでは「変数は宣言しないと使えません！」という命令
‘———————————————————
‘ 文章から単語を抜き出して頻出の高い順に並べる
‘———————————————————
Public Sub sentenceToWords()
Dim fileFullPath As String
Dim maxWords As Long
Dim maxItems As Long
Dim writeWords As Long
startMacro ‘VBA処理速度を上げるためのおまじない
Call Initialize(fileFullPath, maxWords, maxItems, writeWords)
Call extractWordsReset(maxWords)
Call selectTextFile(fileFullPath)
If fileFullPath = “” Then
MsgBox “テキストファイルが選択されていません”
Exit Sub
End If
Call cutWords(fileFullPath, maxWords, maxItems, writeWords)
MsgBox “抜き出し完了”
endMacro ‘VBA処理が終わった後のおまじない
End Sub
‘———————————————————
‘ 変数の初期化
‘———————————————————
Private Sub Initialize( _
ByRef fileFullPath As String, _
ByRef maxWords As Long, _
ByRef maxItems As Long, _
ByRef writeWords As Long _
)
fileFullPath = “”
maxWords = 20000
maxItems = 3
writeWords = 20 ‘ここでエクセルに書きこむ単語数の上位Ｏ位を決める
End Sub
‘———————————————————
‘ [VBAで抜き出した単語リスト]のリセット
‘———————————————————
Private Sub extractWordsReset(ByVal maxWords As Long)
Range(“A2:D” & maxWords + 3).Select
Selection.ClearContents ‘セルの値をクリア
Selection.ClearFormats ‘セルの書式をクリア
End Sub
‘———————————————————
‘ ファイル選択画面を開く
‘———————————————————
Private Sub selectTextFile( _
ByRef fileFullPath As String _
)
ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path
fileFullPath = _
Application.GetOpenFilename( _
FileFilter:=”すべてのファイル,*.*” _
, FilterIndex:=2 _
, Title:=”単語を抜き出す対象のテキストファイルを選択” _
, MultiSelect:=False _
)
End Sub
‘———————————————————
‘ ファイルから単語抜き出す
‘———————————————————
Private Sub cutWords( _
ByRef fileFullPath As String, _
ByRef maxWords As Long, _
ByRef maxItems As Long, _
ByRef writeWordsNum As Long _
)
Dim buf As String
Dim Target As String
Dim tmp As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim wordAddflag As Boolean
Dim strTemp As String
Dim longTemp As Long
Dim jStr() As String
Dim writeWords() As String
Dim writeWordsCount() As Long
Dim writeWordsIndex As Long
ReDim jStr(maxItems)
ReDim writeWords(maxWords)
ReDim writeWordsCount(maxWords)
Target = fileFullPath
i = 0
writeWordsIndex = 0
‘===== ファイルを読み込んで単語を配列に入れる ======
With CreateObject(“ADODB.Stream”)
.Charset = “UTF-8″
.Open
.LoadFromFile Target
Do Until .EOS
buf = .ReadText(-2)
tmp = Split(buf, ” “)
For j = 0 To UBound(tmp)
tmp(j) = cleanWords(tmp(j)) ‘単語にカンマやピリオド等が付いていれば、それを除外
If NonWordCheck(tmp(j)) = False Then ‘除外する文字かチェック
wordAddflag = True
For k = 0 To writeWordsIndex
If tmp(j) = writeWords(k) Then ‘重複する単語が有る場合
wordAddflag = False ‘単語を追加しない
writeWordsCount(k) = writeWordsCount(k) + 1 ‘ヒット数をカウント
Exit For
End If
Next k
If wordAddflag = True Then
writeWords(writeWordsIndex) = tmp(j)
writeWordsCount(writeWordsIndex) = 1
writeWordsIndex = writeWordsIndex + 1
End If
If writeWordsIndex >= maxWords Then
Exit Do
End If
End If
Next j
i = i + 1
Loop
.Close
End With
‘===== 配列をヒット数が多い順にソートする ======
For i = 0 To writeWordsIndex – 1
For j = i To writeWordsIndex
If writeWordsCount(j) > writeWordsCount(i) Then
strTemp = writeWords(j)
longTemp = writeWordsCount(j)
writeWords(j) = writeWords(i)
writeWordsCount(j) = writeWordsCount(i)
writeWords(i) = strTemp
writeWordsCount(i) = longTemp
End If
Next j
Next i
‘===== 配列に入れた単語をエクセルに書きこむ ======
For i = 0 To writeWordsNum – 1
jStr(0) = i + 1
jStr(1) = writeWords(i)
jStr(2) = writeWordsCount(i)
For j = 0 To maxItems – 1
Range(“A2”).Offset(i, j) = jStr(j)
Next j
Next i
‘===== 配列のメモリ領域を解放 ======
Erase jStr
Erase writeWords
Erase writeWordsCount
End Sub
‘———————————————————
‘ 検索から除外すべき文字列かチェック
‘———————————————————
Private Function NonWordCheck(text As Variant) As Boolean
NonWordCheck = True
‘1.数字でないかチェック
If (IsNumeric(text) = True) Then
Exit Function
End If
‘2.特定の文字と一致しないかチェック
Dim j As Integer
Dim jMax As Integer
Dim nonWord() As String
jMax = 10
ReDim nonWord(jMax)
nonWord(0) = “”
nonWord(1) = ” ”
nonWord(2) = “/”
nonWord(3) = “0:00:00”
nonWord(4) = “-”
nonWord(5) = “|”
nonWord(6) = “?”
nonWord(7) = “?”
nonWord(8) = “”
nonWord(9) = “”
For j = 0 To jMax – 1
If text = nonWord(j) Then
Exit Function
End If
Next j
‘2.特定の文字が「含まれていないか？」をチェック
Dim kMax As Integer
Dim nonWordK() As String
kMax = 14
ReDim nonWordK(kMax)
nonWordK(0) = “[”
nonWordK(1) = “]”
nonWordK(2) = “%”
nonWordK(3) = “!”
nonWordK(4) = “#”
nonWordK(5) = “$”
nonWordK(6) = “&”
nonWordK(7) = “‘”
nonWordK(8) = “(”
nonWordK(9) = “)”
nonWordK(10) = “→”
nonWordK(11) = “←”
nonWordK(12) = “↓”
nonWordK(13) = “↑”
For j = 0 To kMax – 1
If InStr(text, nonWordK(j)) > 0 Then
Exit Function
End If
Next j
‘—メモリ解放
Erase nonWord
NonWordCheck = False
End Function
‘———————————————————
‘ 単語にカンマやピリオド等の文字を除外
‘———————————————————
Private Function cleanWords(ByVal text As Variant) As String
cleanWords = text
Dim i As Integer
Dim deleteChar() As String
Dim deleteCharMax As Long
deleteCharMax = 18
ReDim deleteChar(deleteCharMax)
deleteChar(0) = “.”
deleteChar(1) = “,”
deleteChar(2) = “-”
deleteChar(3) = “=”
deleteChar(4) = “-”
deleteChar(5) = “^”
deleteChar(6) = “\”
deleteChar(7) = “|”
deleteChar(8) = “!”
deleteChar(9) = “#”
deleteChar(10) = “$”
deleteChar(11) = “%”
deleteChar(12) = “&”
deleteChar(13) = “‘”
deleteChar(14) = “(”
deleteChar(15) = “)”
deleteChar(16) = “:”
deleteChar(17) = “?”
For i = 0 To deleteCharMax – 1
If (InStr(text, deleteChar(i)) > 0) Then
text = Replace(text, deleteChar(i), “”)
End If
Next i
Erase deleteChar
cleanWords = text
End Function
‘———————————————————
‘ マクロ開始時に画面描写を停止させて処理速度を上げる
‘———————————————————
Private Sub startMacro()
Application.ScreenUpdating = False ‘画面描画を停止
Application.EnableEvents = False ‘イベントを抑止
Application.DisplayAlerts = False ‘確認メッセージを抑止
Application.Calculation = xlCalculationManual ‘計算を手動に
End Sub
‘———————————————————
‘ マクロ終了前に画面描写を再開させる
‘———————————————————
Private Sub endMacro()
Application.StatusBar = False ‘ステータスバーを消す
Application.Calculation = xlCalculationAutomatic ‘計算を自動に
Application.DisplayAlerts = True ‘確認メッセージを開始
Application.EnableEvents = True ‘イベントを開始
Application.ScreenUpdating = True ‘画面描画を開始
End Sub
