今まで調べた単語をたくさん記録しているんだけど、後から探すのが大変・・・
そんな語学マニア向けに、一瞬で単語を探せるプログラムを作った。
このVBAでできること
エクセルに入力した単語を探すのが楽になるぞ！
VBAで単語を探すイメージ
シートの様子
私が作ったマクロのシートは以下のようなレイアウトになっている。
こ↑こ↓が調べた単語を追加していくスペースだよ。
ユーザが設定する内容
黄色のセルに単語を検索するキーワードを入れる。
水色のセルは検索オプションの指定。
1,2,3のどれかの数字を入れるだけ。
１：検索文字を「含む」単語を探す
２：検索文字の始まりから探す
３：検索文字の終わりで探す
試しに動かしてみる
「ab」で始まる英単語だけ抜き出したい！
っていう場合はこんな風に入力して、
下の「単語を抜き出す」ボタンをポチっ・・・とな。
すると、一瞬で該当する単語が書き込まれる。
「ab」で始まる単語がずらーっと出てくるよ！
about
able
absolutely
above
abandoned
ability
absolute
・・・（略）
このプログラムの活用例
単語には一定のルールで文字がくっつく
英単語の場合，「接頭辞」と「接尾辞」が付くことがある。
例を以下に上げる。
接頭辞：ab-,ex-,de-,homo-,inter-,ob-,sub,,,
接尾辞：-able,-er,-fy,-ing,-ster,-tion
同じ接頭辞、接尾辞を整理したい時
例えば「homo-」で始まる英単語を知りたい！
その単語をまとめて覚えたい！
っていう場合はこのマクロを使おう！
（提案）
使用頻度の高い英単語１００００語の中で「homo-」で始まるのは２個だけだと分かる。
homosexual
homo
逆に「-tion」で終わる単語を整理したい場合は・・・
「-tion」で終わる単語を上位２０００位まで整理すると以下になる。
question
situation
information
mention
attention
station
conversation
position
condition
action
connection
investigation
接尾辞ごとに単語をまとめて整理・分析することもできるぞ！
外国語大学の講義のレポートに使って♡
ある文字の組み合わせが存在するかどうか知りたいとき
例えば、英語で「ja」の文字を含む単語はあるのか知りたいとき・・・
検索結果は以下になる。
Benjaminとかhallelujahってなんだよ！（哲学）
こんな風に存在する文字の組み合わせを調べる時にも役に立つ。
このプログラムを動かす方法
拡張子「.xlsm」のエクセルを準備する
エクセルを普通に開いたら、「***.xlsx」になると思う。
左上の「ファイル」をクリックする。
「名前を付けて保存」を選択する。
「Excel マクロ有効ブック(*.xlsm)」を選択して保存する。
これで「***.xlsx」→「***.xlsm」になるよ！
エクセルのシートを編集
シートをは最低でも以下のように入力しておく
詳細を以下に示す。
私が使った単語リストは
Wiktionary:Frequency lists
を参照にしているよ！
単語の意味はgoogle翻訳で一気に翻訳させた。
貼り付けるVBAコード
ソースコードをVBAへ貼り付けてプログラムを動かす方法は以下を参考にして、どうぞ。
以下のテキストをVBAへコピペすればプログラムが動く・・・ハズ。
Option Explicit ‘このモジュールでは「変数は宣言しないと使えません！」という命令
‘———————————————————
‘ 検索した単語を抜き出して書き並べるマクロ
‘———————————————————
Public Sub extractWords()
Dim searchWord As String
Dim searchCondition As Integer
Dim maxWords As Long
Dim maxItems As Long
startMacro ‘VBA処理速度を上げるためのおまじない
If inputErrorCheck = False Then ‘ユーザ入力にエラーが無ければ本処理を実行
Call Initialize(searchWord, searchCondition, maxWords, maxItems) ‘変数の初期化
Call extractWordsReset(maxWords) ‘前回の単語抜き出し結果をリセット
Call SearchWords(searchWord, searchCondition, maxWords, maxItems) ‘単語を抜き出して書き込む
MsgBox “単語抜き出しの完了”
End If
endMacro ‘VBA処理が終わった後のおまじない
End Sub
‘———————————————————
‘ エラーチェック
‘———————————————————
Private Function inputErrorCheck() As Boolean
inputErrorCheck = False ‘Falseのままなら本処理を実行
If Range(“A1”) = “” Then
MsgBox “セル[A1]に検索したい文字を入力して下さい”
Range(“A1”).Select
inputErrorCheck = True ‘処理を実行しない
Exit Function
ElseIf Range(“A2”) = “” Then
MsgBox “セル[A2]に検索フラグを入力して下さい”
Range(“A2”).Select
inputErrorCheck = True ‘処理を実行しない
Exit Function
‘※検索フラグが1,2,3なっているかどうかの判断は本処理で行う
End If
End Function
‘———————————————————
‘ 変数の初期化
‘———————————————————
Private Sub Initialize( _
ByRef searchWord As String, _
ByRef searchCondition As Integer, _
ByRef maxWords As Long, _
ByRef maxItems As Long _
)
searchWord = Range(“A1”).Value ‘検索する文字の設定
searchCondition = Range(“A2”) ‘検索方法の設定（1=含む,2=始めの文字だけ探す）
maxWords = 20000 ‘とりあえず単語は二万語まで対応
maxItems = 4 ‘項目はrank,word,means,countの４つ
End Sub
‘———————————————————
‘ [VBAで抜き出した単語リスト]のリセット
‘———————————————————
Private Sub extractWordsReset(ByVal maxWords As Long)
Range(“J3:M” & maxWords + 3).Select
Selection.ClearContents ‘セルの値をクリア
Selection.ClearFormats ‘セルの書式をクリア
End Sub
‘———————————————————
‘ 単語の検索、書き込み
‘———————————————————
Private Sub SearchWords( _
ByVal searchWord As String, _
ByRef searchCondition As Integer, _
ByVal maxWords As Long, _
ByVal maxItems As Long _
)
Dim i As Long
Dim j As Long
Dim extractFlag As Boolean
Dim objectWord As String
Dim hitWords As Long
Dim readRange As String
Dim writeRange As String
hitWords = 0 ‘検索で見つかった単語数をカウントする変数の初期化
For i = 1 To maxWords
If Range(“D” & 2 + i).Value = “” Then ‘項目rankが空の場合・・・
Exit For ‘これ以上検索する単語が無いと判断してループをぬける
End If
objectWord = Range(“E” & 3 + i).Value ‘単語を抜き出す
If InStr(objectWord, searchWord) > 0 Then ‘単語がユーザ検索の単語とヒットした時
‘検索方法によって書きこむか否かを判断
If searchCondition = 1 Then ‘文字を含む場合
extractFlag = True ‘そのまま抽出
ElseIf searchCondition = 2 Then
If InStr(objectWord, searchWord) = 1 Then ‘最初の文字だけ見る
extractFlag = True ‘抽出ＯＫ
Else
extractFlag = False ‘抽出ダメ
End If
ElseIf searchCondition = 3 Then ‘最後の文字だけ見る
If InStr(objectWord, searchWord) = Len(objectWord) – Len(searchWord) + 1 Then ‘最初の文字だけ見る
extractFlag = True ‘抽出ＯＫ
Else
extractFlag = False ‘抽出ダメ
End If
Else
MsgBox “検索フラグは1,2,3のどれかを入力して下さい”
Range(“A2”).Select
Exit Sub
End If
If extractFlag = True Then ‘抽出フラグが立った場合だけ書き込み
For j = 1 To maxItems
readRange = “D” & 3 + i ‘単語読み込みのアドレス
writeRange = Range(“J3”).Offset(0 + hitWords, j – 1).Address ‘単語書き込みのアドレス
Range(writeRange).Value = Range(readRange).Offset(0, j – 1) ‘抽出した情報の書き込み
If j = 2 Then ‘ヒットした単語の該当する文字だけ赤太字にする
Call changeRedFutoji(writeRange, objectWord, searchWord)
End If
Next j
hitWords = hitWords + 1
End If
End If
Next i
End Sub
‘———————————————————
‘ ヒットした単語の文字を赤太字にする
‘———————————————————
Private Sub changeRedFutoji( _
ByVal writeRange As String, _
ByVal objectWord As String, _
ByVal searchWord As String _
)
Dim charStartPlace As Long ‘赤太字にする文字の開始位置
Dim charLength As Long ‘赤太字にする文字の長さ
Dim redCode As Long
redCode = -16776961 ‘赤文字のコード
Range(writeRange).Select ‘赤太字にするセルを選択
charStartPlace = InStr(objectWord, searchWord) ‘赤文字にする文字の開始番号
charLength = Len(searchWord) ‘赤文字にする文字の長さ
Call setCellInfo(charStartPlace, charLength, “太字”, redCode)
End Sub
‘———————————————————
‘ セル書式の設定
‘———————————————————
Private Sub setCellInfo( _
ByVal charStartPlace As Long, _
ByVal charLength As Long, _
ByVal FontStyle_IN As String, _
ByVal colorCode As Long _
)
With ActiveCell.Characters(Start:=charStartPlace, Length:=charLength).Font
.Name = “ＭＳ Ｐゴシック” ‘フォント
.FontStyle = FontStyle_IN ‘太字等に変える
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.Color = colorCode ‘文字の色を変更
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
End Sub
‘———————————————————
‘ マクロ開始時に画面描写を停止させて処理速度を上げる
‘———————————————————
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
必要であれば各自で修正して、どうぞ。
