アンケートで条件から抽出し分類するマクロ エクセル

質問

製品のアンケートをまとめたいと思っておりますが、マクロを習いたてのため上手くいきません。
（試行錯誤でいろいろやりましたが、できませんでした。再度ご質問させていただきます。）
１セルにあるコメント（文字列）から複数あるキー検索し、キーの多いものを、そのコメントの結果にしたいです。

------------------------------------------------
検索グループと検索キー
検索グループA：　ゆるい、かたい、キズ
検索グループB：　ゆるい、きれい、はがれ
検索グループC：　かたい、よわい、はがれ
※検索グループは全部で、100グループあります。
------------------------------------------------
コメント１：　ゆるいがかたい。　→検索グループA：ゆるい、かたい→２個該当（最大個数）
　　　　　　　　　　　　　　　　　　　→検索グループB：ゆるい　→１個該当
　　　　　　　　　　　　　　　　　　　→検索グループC：かたい　→１個該当

コメント２：　よわいがはがれる。→検索グループA：　　　　　　　　　　→０個該当
　　　　　　　　　　　　　　　　　　　→検索グループB：はがれ　　　　　　→1個該当
　　　　　　　　　　　　　　　　　　　→検索グループC：よわい、はがれ　→２個該当（最大個数）
※コメントは全部で２０００件あります。
------------------------------------------------
よって、コメント１については、”検索グループA”をコメント１の横に表示したい。
コメント２については、”検索グループC”をコメント２の横に表示したい。

●●●以下のように表示したいです。●●●
（Sheet１）
　　　　A　　　　　　　　　　B　　　　C 　　　D　　　　　　E
１　検索グループA：　ゆるい　かたい　キズ　　　　　 ２　※２
２　検索グループB：　ゆるい　きれい　はがれ　　　 １
３　検索グループC：　かたい よわい　はがれ　　　 1

※１　検索グループは他に１００件あります。
※２　コメント１の中に含まれる検索キー数の最大値です。（この場合”２”、つまり検索グループAを結果に引用）
※３　（Sheet１）のA1：E3・・・・は（Sheet2）のコメント１の検索グループが表示された後、クリアし繰り返し使用します。
※　使用するマクロは”ｘｘｘｘ.Find(What:=IDNo, LookIn:=xlValues, LookAt:=xlPart）を考えておりました。

（Sheet２）
　　　　A　　　　　　　　　B　　　　
１　コメント１　　検索グループA（←検索グループAと表示）
２　コメント２　　検索グループC（←検索グループCと表示）
３　コメント３　　検索グループ・・・（←上記と同様に判定し表示）
以後２０００件

どなたかお助けくださいますでしょうか。よろしくお願いします。
（OS：WindowsXP、Excel2003）

回答No.2

don9don9 · ベストアンサー

Sheet1のE1に

=ISNUMBER(FIND(B1,Sheet2!A1))+ISNUMBER(FIND(C1,Sheet2!A1))+ISNUMBER(FIND(D1,Sheet2!A1))

という式を入れると、Sheet2のA1のコメントが
B1:D1の3つのキーワードのうち、いくつに合致しているかを返します。
この式をE100まで入れたら

=INDEX(Sheet1!A1:A100,MATCH(MAX(Sheet1!E1:E100),Sheet1!E1:E100,FALSE))

という式で、該当する検索グループを返すことができます。
（※最大値が同値で複数ある場合は、上にある方が優先されます）

これをSheet2の2000行分、ループさせるような形です。
処理にちょっと時間がかかるかもしれませんが…

Sub データ検索()
Dim m As Long
Dim n As Long
Sheet2.Range("B1:B2000").ClearContents
For m = 1 To 2000
If Sheet2.Cells(m, 1) <> "" Then
Sheet1.Range("E1:E100").ClearContents
For n = 1 To 100
If Sheet1.Cells(n, 1) <> "" Then
Sheet1.Cells(n, 5).Formula = "=ISNUMBER(FIND(B" & n & ",Sheet2!A" & m & "))+ISNUMBER(FIND(C" & n & ",Sheet2!A" & m & "))+ISNUMBER(FIND(D" & n & ",Sheet2!A" & m & "))"
End If
Next n
Sheet2.Cells(m, 2) = Application.WorksheetFunction.Index(Sheet1.Range("A1:A100"), Application.WorksheetFunction.Match(Application.WorksheetFunction.Max(Sheet1.Range("E1:E100")), Sheet1.Range("E1:E100"), False))
End If
Next m
Sheet1.Range("E1:E100").ClearContents
End Sub

お礼

まずお礼申し上げます。こんなにスラスラ書けたら（努力のたまものでしょうが・・・）うらやましく思います。これを参考にしマクロを勉強したいと思います。まず、いただいたアイディアを実行してみます。またお返事いたします。見知らぬ方にこうして頂き心強く思います。ありがとうございます。

回答No.1

web2525

コメントの分割が最大の難点になるのではないでしょうか？
コメントは全て日本文で"が"が検索の区切りになっていて、検索する単語自体に"が"の文字が含まれて居ないのであれば問題は無いのですが、その点はいかがでしょうか？

検索する単語の区切り文字が複数存在していたり、検索単語自体に区切り文字が使われていると、コメントの検索単語の分割自体が不可能になります

お礼

アドバイスありがとうございます。コメント自体はセル毎に分割済みですぐマクロさえできれば、作業できる段階です。また、下記のようにやってみましたが、（大分検討違いですが・・・）単独フレーズから単独条件をあてることはできますが、複数対複数の検索ができません。よろしくお願いします。

----------------------------
Sub 同じ条件でデータ検索()
Dim myRange As Range, srcRange As Range, myAddress As String, i As Integer
Set srcRange = Range("C22")

Set myRange = srcRange.Find(What:=Range("D30").Rows(1).Value, LookIn:=xlValues, LookAt:=xlPart, MatchByte:=False) 'myRangeは検索結果を格納中

If Not myRange Is Nothing Then
myAddress = myRange.Address

i = 9
Do
Cells(30, i).Value = myRange.Offset(, -1).Value
Set myRange = srcRange.FindNext(After:=myRange)
i = i + 1
Dim LastRowIndex As Long
Dim LastColumnIndex As Long
・・・・・・など未完成です。。。