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

Question

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

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

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

よろしくお願いします。

keithin · Accepted Answer

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

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

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

前回並べた単語を除外したいという事ですか？いままでにやった結果(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

tom04 · Answer

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

keithin · Answer

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

一応高速版：
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

みたいな。

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

tom04 · Answer

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

tom04 · Answer

こんばんは！
＞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

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

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

No.1・2です。

２０ページというと１万ワードぐらい？

この回答への補足

No.1です。

この回答への補足

こんばんは！

この回答への補足

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング