エクセルを使って英文から単語の抽出

質問

このようなことがエクセルでできますか。

20ページほどの英文があります。そこに出てくる単語を重複しないようにして、抽出したいのです。

自分でやってみるのですが、なかなかうまくいきません。
もし、できるようであればその方法を教えてください。

よろしくお願いします。

回答No.5

keithin · ベストアンサー

＞しょっちゅう出てくる基本語や

実際にやってみると、出てくる数が「少ない」のがイイ単語ではありませんよ。

＞一度出てきた語を除外して抽出

前回並べた単語を除外したいという事ですか？いままでにやった結果(or除外したいワード)をどこにどう取り置きしておきたいのか不明なのと、あんまり後出しダラダラあれもこれもと際限なくなるのはカンベンなので、次の課題別のご相談にしてください。

Sub macro1r1()
　Dim mydic As Object
　Dim h As Range
　Dim s As String
　Dim a, ax, buf, res
　Set mydic = CreateObject("Scripting.Dictionary")

'除外文字
　a = Array(",", ".", "/", "?", "!", ":", ";", "$", """", "(", ")", "[", "]", "'s")

　On Error Resume Next
　For Each h In Cells.SpecialCells(xlCellTypeConstants)
　　s = h.Value
　　For Each ax In a
　　　s = Replace(s, ax, " ")
　　Next

　　For Each ax In Split(Application.Trim(s), " ")
　　　buf = StrConv(ax, vbLowerCase)
　　　mydic(buf) = mydic(buf) + 1
　　Next
　Next

　With Worksheets("Sheet2")
　　.cells.clearcontents
　　res = mydic.keys
　　.Range("A2").Resize(mydic.Count, 1) = Application.Transpose(res)
　　res = mydic.items
　　.Range("B2").Resize(mydic.Count, 1) = Application.Transpose(res)
　　.Range("A1:B1") = Array("WORD", "COUNT")
　　.Columns("A:B").AutoFit
　　.Range("A:B").Sort key1:=.Range("B1"), order1:=xlAscending, key2:=.Range("A1"), order2:=xlAscending, header:=xlYes
　End With

End Sub

お礼

早速の対処ありがとうございました。２度までも丁寧にコード作成していただき感謝します。
ご指摘のように回数だけで単語の取捨選択はできるものではありません。
自分の目で見て選んでいくべきですね。
しかし、頻出回数が分かるので大いに参考になりますし、助かります。

以前に並べた単語を下にくつけてやってみましたが、語数が増えるばかりでこれもしんどいとわかりました。

おかげさまで私の希望がだいぶ叶えられましたので喜んでいます。
お手数をおかけしました。厚く御礼申し上げます。
明日、ベストアンサーに選ばせていただきます。

回答No.4

tom04

No.1・2です。
＞しょっちゅう出てくる基本語や、一度出てきた語を除外して抽出する、なんてことができますかね。
とありましたので・・・

前回のコードの
＞Next j
＞End If
の2行の間に
If wS2.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
cnt = wS2.Cells(Rows.Count, 1).End(xlUp).Row
Else
cnt = 0
End If

の5行を追加してみてください。
（Sheet2の表示されているデータはそのまま残し、Sheet1のA1セル以降に新しいデータをコピー＆ペーストします）

おそらくこれで一度出現している「単語」は表示されないはずです。

※　今回も前回同様時間を要すると思います。m(_ _)m

お礼

3度もご対応ありがとうございました。
ちょっとパソコンを買い替えないと動きが悪くて困ります。
新しくiMacを買ったのですが、 excelはまだ入れていません。

教えていただいたコードを保存しておき、また利用させていただきます。
ありがとうございました。

回答No.3

keithin

２０ページというと１万ワードぐらい？
それならベタ打ちして後から重複除外しても、大丈夫そうですね。

一応高速版：
sub macro1()
　dim mydic as object
　dim h as range
　dim s as string
　dim a, ax, res
　set mydic = createobject("Scripting.Dictionary")

’除外文字
　a = array(",", ".", "/", "?", "!", ":", ";", """", "'s")

　on error resume next
　for each h in cells.specialcells(xlcelltypeconstants)
　s = h.value
　for each ax in a
　　s = replace(s, ax, " ")
　next

　for each ax in split(application.trim(s), " ")
　　mydic.add strconv(ax, vblowercase), ""
　next
　next

　res = mydic.keys
　worksheets("sheet2").range("a1").resize(mydic.count, 1) = application.transpose(res)
end sub

みたいな。

＃ハイフネーションを元の単語に戻すみたいな、ワープロ機能を付けだすとどんどん際限なくなっていきます。
活用形とか複数形とかは、まぁあんまりエクセルでやっつける範疇外のように思います。

補足

本当に一瞬で抽出しましたので感動しました。
昨日と今日でこれで2冊分を抽出できました。

思い通りできてうれしいのですが、また新たな問題に出くわしました。

私の狙いは英文を読んだときに、知らない単語や、あやふやと思う単語を抽出して学習したかったのです。

ところが毎回1万や5,000語の単語から、100～ 200の単語を選ぶのは大変だと気づきました。

しょっちゅう出てくる基本語や、一度出てきた語を除外して抽出する、なんてことができますかね。

勝手なことを言って申し訳ありませんが、何かヒントになるようなことでも教えていただけたら幸いです。
よろしくお願いします。

回答No.2

tom04

No.1です。
補足に
＞「”」だけが消去できません
とありましたので、再びお邪魔します。

この際ですので、Sheet2のA列に重複なく表示させ、昇順に並び替えてみました。
↓のコードでマクロを実行してみてください。

Sub Sample2()
Dim i As Long, j As Long, k As Long, cnt As Long, c As Range, myArray1, myArray2, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
myArray2 = Array(".", "!", "?", """") '←「"」ダブルクォーテーションを追加しています。
For i = 1 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
myArray1 = Split(wS1.Cells(i, 1), " ")
For k = 0 To UBound(myArray1)
wS2.Range("B1") = myArray1(k)
For j = 0 To UBound(myArray2)
wS2.Range("B1") = Replace(wS2.Range("B1"), myArray2(j), "")
Next j
Set c = wS2.Range("A:A").Find(what:=wS2.Range("B1"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
cnt = cnt + 1
wS2.Cells(cnt, 1) = wS2.Range("B1")
End If
Next k
Next i
wS2.Range("B1").ClearContents
wS2.Range("A:A").Sort key1:=wS2.Cells(1, 1), order1:=xlAscending, Header:=xlNo
End Sub

※　For～Nextを多用していますので、時間がかかるかもしれません。
今度はどうでしょうか？m(_ _)m

補足

度々お手数をおかけして申し訳ありません。ありがとうございました。

やはり時間がかかりましたね。もともと私のWINDOWS XPは速度が遅くなっていたのですが、これをした時はフリーズしたのかと思うぐらい忘れた頃に抽出していました。

昨日と今日でこれで2冊分を抽出できました。

思い通りできてうれしいのですが、また新たな問題に出くわしました。

私の狙いは英文を読んだときに、知らない単語や、あやふやと思う単語を抽出して学習したかったのです。

ところが毎回1万や5,000語の単語から、100～ 200の単語を選ぶのは大変だと気づきました。

しょっちゅう出てくる基本語や、一度出てきた語を除外して抽出する、なんてことができますかね。

勝手なことを言って申し訳ありませんが、何かヒントになるようなことでも教えていただけたら幸いです。
よろしくお願いします。

回答No.1

tom04

こんばんは！
＞20ページほどの英文があります
とありますが、
ExcelのSheet1のA1セル以降に英文があるとします。
英文の場合は半角スペースで単語毎に区切られるはずですので、それを利用しています。

VBAになりますが一例です。
Sheet2にA列に単語を表示するようにしてみました。
Alt+F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample() 'この行から
Dim i As Long, k As Long, cnt As Long, c As Range, myArray, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
For i = 1 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
myArray = Split(wS1.Cells(i, 1), " ")
For k = 0 To UBound(myArray)
Set c = wS2.Range("A:A").Find(what:=myArray(k), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
cnt = cnt + 1
wS2.Cells(cnt, 1) = myArray(k)
End If
Next k
Next i
End Sub 'この行まで

尚、通常英文は文章の最後に「.」（ピリオド）や「？」（疑問符）・「！」（感嘆符）等がついていると思いますが
それらは考慮していません。
もしそれらを消したい場合、Sheet2にデータが表示されたのちに↓のマクロを実行してみてください。

Sub 符号消去()
Dim i As Long, k As Long, myArray, wS As Worksheet
Set wS = Worksheets("Sheet2")
myArray = Array("!", "?", ".")
For i = 1 To wS.Cells(Rows.Count, 1).End(xlUp).Row
For k = 0 To UBound(myArray)
If InStr(wS.Cells(i, 1), myArray(k)) > 0 Then
wS.Cells(i, 1) = Replace(wS.Cells(i, 1), myArray(k), "")
End If
Next k
Next i
End Sub

※　消去するのは「!」・「?」・「.」だけにしていますので、他の符号はArrayの中に追加してみてください。

こんなんではどうでしょうか？m(_ _)m

補足

早速にご回答いただきありがとうございました。
Windows XPの調子が悪く、ネットにつながらずやきもきしていました。（iMac ではメールとサイトを見ておりました）
先程やっとつながり、教えていただいたコードをコピーして試しました。

あまりにもうまくできたので感動しました。

アルファベット順に並び替えてみると、同じ単語がいくつか出てくるのに気づきました。
２つのコードを繰り返してうまく消すことができました。

1つおたずねしたいのですが、「”」だけが消去できません。
何か方法がありますか？
よろしくお願いいたします。