エクセルでキーワードの検索分析の方法２

Question

エクセルで、sheet1のA列に語句に対して、sheet2のキーワード表で一致した場合、
sheet2のキーワード表のA列の語を入れ込むマクロがあります。

サンプルを添付しました。
http://yahoo.jp/box/D5A4U9

そこで、sheet1で新しい語がある場合にB列の「新規語句」に”１”とでるようにしたいです。
サンプルのシートでいう　４行目の「りんご 青森」（りんごはあるけど青森がないので１）
５行目の「山梨　ぶどう 」（山梨もぶどうも存在する）ので１はなし）

１１行目の｢大阪　天丼」（天丼はあるけど、大阪ははないので１）

このような表をチェックできるようなマクロはないでしょうか。
前回に続いて同じ内容の質問をして申し訳ないのですが、わかる方教えていただけないでしょうか。

30246kiku · Accepted Answer

＃７です
　　　　vA(i, 1) = Mid(vB, 2) '☆ OK
↓
　　　　vA(i, 1) = mySort2(Mid(vB, 2)) '☆ OK

Samp2 の上記を変更の上、以下を追加してみてください

Private Function mySort2(sSrc As String) As String
　　Dim dic As Object
　　Dim vA As Variant, v As Variant
　　Dim i As Long, j As Long

mySort2 = sSrc
　　If (InStr(1, sSrc, ",") = 0) Then Exit Function
' ★～
　　Set dic = CreateObject("Scripting.Dictionary")
　　dic.CompareMode = vbTextCompare
　　For Each v In Split(sSrc, ",")
　　　　dic(v) = Empty
　　Next
　　vA = dic.Keys
　　Set dic = Nothing
' ～★
　　For i = 0 To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (StrComp(vA(i), vA(j), vbTextCompare) > 0) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySort2 = Join(vA, ",")
End Function

※ ' ★～　～★ 間は、「リンゴ　大　ﾐｶﾝ」時の
「くだもの,サイズ,くだもの」を「くだもの,サイズ」にまとめるものです。
まとめたくない場合は、★～　～★ 間を以下１行に。

vA = Split(sSrc, ",")

※ 上記並べ替えは、くだもの、サイズ、の比較になります。
もし、「キーワード一覧」に記述した分類順なら全面的に以下に変更。
なお、文字比較する InStr / Split / Replace 等で
vbTextCompare 指定しなくても良いように
Option Compare Text を宣言しておく例になるかも

Option Explicit
Option Compare Text

Public Sub Samp3()
　　Dim dic As Object, dicW As Object, dicS As Object
　　Dim vA As Variant, v As Variant
　　Dim vB As Variant, vC As Variant
　　Dim vElm As Variant
　　Dim sS As String
　　Dim i As Long, j As Long
　　Const CNONE As Long = 1

With Worksheets("集計")
　　　　i = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　If (i = 1) Then Exit Sub
　　　　Set dic = CreateObject("Scripting.Dictionary")
　　　　Set dicW = CreateObject("Scripting.Dictionary")
　　　　Set dicS = CreateObject("Scripting.Dictionary")
　　　　Call MakeDic3(dic, dicW, dicS)
　　　　With .Cells(2, "A").Resize(i - 1)
　　　　　　vA = .Resize(, 2).Value
　　　　　　For i = 1 To UBound(vA)
　　　　　　　　vB = ""
　　　　　　　　vC = Empty
　　　　　　　　sS = vA(i, 1)
　　　　　　　　If (InStr(1, sS, " ") > 0) Then
　　　　　　　　　　sS = " " & sS & " "
　　　　　　　　　　For Each v In dicW.Keys
　　　　　　　　　　　　If (InStr(1, sS, " " & v & " ") > 0) Then
　　　　　　　　　　　　　　sS = Replace(sS, v, "")
　　　　　　　　　　　　　　vB = vB & dicW(v)
　　　　　　　　　　　　End If
　　　　　　　　　　Next
　　　　　　　　　　sS = Trim(sS)
　　　　　　　　End If
　　　　　　　　For Each vElm In Split(sS, " ")
　　　　　　　　　　If (Len(vElm) > 0) Then
　　　　　　　　　　　　If (dic.Exists(vElm)) Then
　　　　　　　　　　　　　　vB = vB & dic(vElm)
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　vC = CNONE
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Next
'　　　　　　　　vA(i, 1) = Mid(vB, 2) '★
　　　　　　　　vA(i, 1) = mySort3(Mid(vB, 2), dicS) '★
　　　　　　　　vA(i, 2) = vC
　　　　　　Next
　　　　　　.Offset(, 5).Resize(, 2).Value = vA
　　　　End With
　　　　Set dic = Nothing
　　　　Set dicW = Nothing
　　　　Set dicS = Nothing
　　End With
End Sub

Private Function mySort3(sSrc As String, dicS As Object) As String
　　Dim dic As Object
　　Dim vA As Variant, v As Variant
　　Dim i As Long, j As Long

mySort3 = sSrc
　　If (InStr(1, sSrc, ",") = 0) Then Exit Function
' ★～
　　Set dic = CreateObject("Scripting.Dictionary")
　　dic.CompareMode = vbTextCompare
　　For Each v In Split(sSrc, ",")
　　　　dic(v) = Empty
　　Next
　　vA = dic.Keys
　　Set dic = Nothing
' ～★
　　For i = 0 To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (dicS(vA(i)) > dicS(vA(j))) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySort3 = Join(vA, ",")
End Function

Private Sub MakeDic3(dic As Object, dicW As Object, dicS As Object)
　　Dim vA As Variant
　　Dim i As Long, j As Long

dic.CompareMode = vbTextCompare
　　dicW.CompareMode = vbTextCompare
　　dicS.CompareMode = vbTextCompare
　　With Worksheets("キーワード表")
　　　　i = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　j = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　vA = .Range("A1").Resize(i, j).Value
　　　　For i = 2 To UBound(vA)
　　　　　　If (Not dicS.Exists(vA(i, 1))) Then
　　　　　　　　dicS(vA(i, 1)) = dicS.Count
　　　　　　End If
　　　　　　For j = 2 To UBound(vA, 2)
　　　　　　　　If (vA(i, j) = "") Then Exit For
　　　　　　　　If (InStr(1, vA(i, j), " ") > 0) Then
　　　　　　　　　　dicW(vA(i, j)) = dicW(vA(i, j)) & "," & vA(i, 1)
　　　　　　　　Else
　　　　　　　　　　dic(vA(i, j)) = dic(vA(i, j)) & "," & vA(i, 1)
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
End Sub

30246kiku · Answer

＃６です

> 集計シートの　B列　C列を変えたい場合どうすればいいでしょうか・・・

これは、今までのサンプル B / C 列が F / G 列になったということになりますか？
であれば

>　　　　　　 .Offset(, 1).Resize(, 2).Value = vA '☆
> '　　　　　　.Offset(, 2).Value = vA ' ★

上記の .Offset(, x)　の x を変更します。
☆ の場合、２列分のデータを vA に作っていたので、

>　　　　 With .Cells(2, "A").Resize(i - 1)

この位置から、右に１つ移動したところから２列分･･･
なので、.Offset(, 1).Resize(, 2).Value　すると、B / C 列に結果を展開

★ の場合、２列分ある vA の１列目にしか値を設定していないので
右に２つ移動したところに、vA は２列分あるんだけど１列分だけを設定するように
.Offset(, 2).Value

このことから、F / G 列に設定するときには、元々が A列だったので
☆ の場合、右に５つ移動して２列分
★ の場合、右に６つ移動して１列分

>　　　　　　 .Offset(, 5).Resize(, 2).Value = vA '☆
> '　　　　　　.Offset(, 6).Value = vA ' ★

※ この解釈でよかったでしょうか

余談）

☆で分類の作り直し、新規語句の２列分を vA に作っていたとして
分類部分は F 列に、新規語句部分は H 列に（離れて設定したい場合）

.Offset(, 5).Value = vA '☆
　　.Offset(, 7).Value = WorksheetFunction.Index(vA, 0, 2) '☆

と分けて設定すればよいです。

30246kiku · Answer

＃５です

では、以下でどうでしょう

☆ が有効（以下そのまま）なら、集計の分類も作り直します。
☆ をコメント ＆ ★ を有効にすると新規語句のみチェックします。

Dictionary は１段構成の dic / dicW の２つを使用
dic は語のみ、dicW はスペースを含む語のみ
キーワード表への記述は
スペースを含む語は " " で囲む必要はなく、そのままで。
Dictionary で語を覚える際には、無条件で分類を追加していくので、
例えば、
「くだもの」に、みかん、ミカン の様に複数記述していたら、
☆で作成される集計の分類は、くだもの,くだもの になります。
また、みかん が中華にも記述されていたら、くだもの,中華 になります。

※ キーワード表に記述する語は左詰めで･･･
なお、同じ分類が何行あっても構いません。

※ ▲▲部分を有効にすると、分類の作り直し表示が変わります
無効のままでは、
「りんご 青森」「青森 りんご」どちらも「くだもの」
有効にすると
「りんご 青森」は「くだもの」、「青森 りんご」は空白
つまり、有効にすると無い語を見つけた時点でチェック処理が終わるので････

Option Explicit

Public Sub Samp2()
　　Dim dic As Object, dicW As Object
　　Dim vA As Variant, v As Variant
　　Dim vB As Variant, vC As Variant
　　Dim vElm As Variant
　　Dim sS As String
　　Dim i As Long, j As Long
　　Const CNONE As Long = 1

With Worksheets("集計")
　　　　i = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　If (i = 1) Then Exit Sub
　　　　Set dic = CreateObject("Scripting.Dictionary")
　　　　Set dicW = CreateObject("Scripting.Dictionary")
　　　　Call MakeDic2(dic, dicW)
　　　　With .Cells(2, "A").Resize(i - 1)
　　　　　　vA = .Resize(, 2).Value
　　　　　　For i = 1 To UBound(vA)
　　　　　　　　vB = ""
　　　　　　　　vC = Empty
　　　　　　　　sS = vA(i, 1)
　　　　　　　　If (InStr(1, sS, " ", vbTextCompare) > 0) Then
　　　　　　　　　　sS = " " & sS & " "
　　　　　　　　　　For Each v In dicW.Keys
　　　　　　　　　　　　If (InStr(1, sS, " " & v & " ", vbTextCompare) > 0) Then
　　　　　　　　　　　　　　sS = Replace(sS, v, "", , , vbTextCompare)
　　　　　　　　　　　　　　vB = vB & dicW(v)
　　　　　　　　　　　　End If
　　　　　　　　　　Next
　　　　　　　　　　sS = Trim(sS)
　　　　　　　　End If
　　　　　　　　For Each vElm In Split(sS, " ", , vbTextCompare)
　　　　　　　　　　If (Len(vElm) > 0) Then
　　　　　　　　　　　　If (dic.Exists(vElm)) Then
　　　　　　　　　　　　　　vB = vB & dic(vElm)
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　vC = CNONE
'　　　　　　　　　　　　　　Exit For ' ▲▲
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　vA(i, 1) = Mid(vB, 2) '☆
　　　　　　　　vA(i, 2) = vC '☆
'　　　　　　　　vA(i, 1) = vC ' ★
　　　　　　Next
　　　　　　.Offset(, 1).Resize(, 2).Value = vA '☆
'　　　　　　.Offset(, 2).Value = vA ' ★
　　　　End With
　　　　Set dic = Nothing
　　　　Set dicW = Nothing
　　End With
End Sub

Private Sub MakeDic2(dic As Object, dicW As Object)
　　Dim vA As Variant
　　Dim i As Long, j As Long

dic.CompareMode = vbTextCompare
　　dicW.CompareMode = vbTextCompare
　　With Worksheets("キーワード表")
　　　　i = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　j = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　vA = .Range("A1").Resize(i, j).Value
　　　　For i = 2 To UBound(vA)
　　　　　　For j = 2 To UBound(vA, 2)
　　　　　　　　If (vA(i, j) = "") Then Exit For
　　　　　　　　If (InStr(1, vA(i, j), " ", vbTextCompare) > 0) Then
　　　　　　　　　　dicW(vA(i, j)) = dicW(vA(i, j)) & "," & vA(i, 1)
　　　　　　　　Else
　　　　　　　　　　dic(vA(i, j)) = dic(vA(i, j)) & "," & vA(i, 1)
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
End Sub

30246kiku · Answer

＃４です

> 標準モジュールに＃３の内容で
> 「リンゴ」、「ﾘﾝｺﾞ」「ル ルクチェ」を入れてやってみたのですが、
> キーワード表に存在しているのに「１」がでてしまいました。

私の解釈が間違っていたのかもしれませんが、
シート「集計」の B列 のものが「キーワード表」の分類であり、
その分類の中での有り/無しと思っていました。

１６行目～１９行目の B列に「くだもの」を設定して確認してみてください。
この際、「ル ルクチェ」に関しては、
「ル」と「ルクチェ」に区切って確認しているので 1 になります。
これを解釈するために、以下の★部分（２行）を追加してみてください。
１度全部の文字列で語チェック後、なければスペース区切りで確認します。

sS = Replace(vA(i, 1), "　", " ") ' スペース全角→半角
　　　　　If (Not dic(vA(i, 2)).Exists(sS)) Then ' ★
　　　　　　　For Each vElm In Split(sS, " ")
　　　　　　　　　If (Len(vElm) > 0) Then
　　　　　　　　　　　If (Not dic(vA(i, 2)).Exists(vElm)) Then
　　　　　　　　　　　　　v = CNONE
　　　　　　　　　　　　　Exit For
　　　　　　　　　　　End If
　　　　　　　　　End If
　　　　　　　Next
　　　　　End If ' ★

※ ただし、この変更を入れたとして、
「ル ルクチェ 山梨」の場合は 1 になりますけど････

※ 語のチェックは分類に関係ない場合は補足をお願いします。
Dictionary でのデータの持ち方等変更しないといけないので････

※ どの状態の時に、どうしたいのか･･･まとめてもらえればと
ご質問時点での文面では、シート「集計」の B列は新規語句のようでしたが、
サンプルでは検索となっており、
これを分類と解釈し、その中での語チェックをしたものです。

30246kiku · Answer

＃３です

> キーワード表に"りんご"と"リンゴ"をそれぞれいれたのですが、
> それでも「１」になってしまいました。
> カタカナが対応していないみたいです・・・・

ごめんなさい。これについては再現できません

処理を説明しておきます
シート「キーワード表」を Dictionary に覚えます
Dictionary は２段構成で
１段目キー：分類
２段目キー：語
キーに文字列を指定して、
キーの重複は、ひらがな/カタカナ、大文字/小文字、全角/半角を区別しないように
CompareMode を vbTextCompare に設定しています。

Dictionary に覚える際、りんご / リンゴ は先に出現した方を覚えます
なので「キーワード表」には、どちらか一方指定していれば良いです。
シート「集計」の語をスペース区切りして、区切った文字列が Dictionary にあるか･･･
この「あるか」は、覚える時のように、
ひらがな/カタカナ、大文字/小文字、全角/半角は区別されないので････

なので
> あと「ル ルクチェ」のように半角を含めた語句の対応ってむずかしいでしょうか？

これも問題ないと思いますが･･･
（どこが半角かわかりませんけど）

※ 私が確認した手順（ Vista + 2007 ）

・サンプルファイルを入手
・標準モジュールに＃３の内容を記述
・xlsm で保存
・シート「集計」の A3 りんご を　全角リンゴ、半角ﾘﾝｺﾞ、混在ﾘﾝゴ
　等々に書き換え実行しても、新規語句は 1 にならない
また、A8 の めろん を メロン 等に書き換えてみても結果は同じ

30246kiku · Answer

以下でどうなりますか

りんご　リンゴ
めろん　メロン

は、同じものとして判別します
サンプルファイルの１６行目は 1 になります

Public Sub Samp1()
　　Dim dic As Object
　　Dim vA As Variant, v As Variant
　　Dim vElm As Variant
　　Dim sS As String
　　Dim i As Long, j As Long
　　Const CNONE As Long = 1

With Worksheets("集計")
　　　　i = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　If (i = 1) Then Exit Sub
　　　　Set dic = CreateObject("Scripting.Dictionary")
　　　　Call MakeDic(dic)
　　　　With .Cells(2, "A").Resize(i - 1)
　　　　　　vA = .Resize(, 2).Value
　　　　　　For i = 1 To UBound(vA)
　　　　　　　　v = Empty
　　　　　　　　If (dic.Exists(vA(i, 2))) Then
　　　　　　　　　　sS = Replace(vA(i, 1), "　", " ") ' スペース全角→半角
　　　　　　　　　　For Each vElm In Split(sS, " ")
　　　　　　　　　　　　If (Len(vElm) > 0) Then
　　　　　　　　　　　　　　If (Not dic(vA(i, 2)).Exists(vElm)) Then
　　　　　　　　　　　　　　　　v = CNONE
　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　Next
　　　　　　　　Else
　　　　　　　　　　v = CNONE
　　　　　　　　End If
　　　　　　　　vA(i, 1) = v
　　　　　　Next
　　　　　　.Offset(, 2).Value = vA
　　　　End With
　　　　Set dic = Nothing
　　End With
End Sub

Private Sub MakeDic(dic As Object)
　　Dim vA As Variant
　　Dim i As Long, j As Long

dic.CompareMode = vbTextCompare
　　With Worksheets("キーワード表")
　　　　i = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　j = .Cells(1, Columns.Count).End(xlToLeft).Column
　　　　vA = .Range("A1").Resize(i, j).Value
　　　　For i = 2 To UBound(vA)
　　　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　　　dic.Add vA(i, 1), CreateObject("Scripting.Dictionary")
　　　　　　　　dic(vA(i, 1)).CompareMode = vbTextCompare
　　　　　　End If
　　　　　　For j = 2 To UBound(vA, 2)
　　　　　　　　If (vA(i, j) = "") Then Exit For
　　　　　　　　dic(vA(i, 1))(vA(i, j)) = Empty
　　　　　　Next
　　　　Next
　　End With
End Sub

※ 記述についての説明が必要なら補足ください

tom04 · Answer

No.1です。
たびたびごめんなさい。
前回のコードは消去して↓のコードに変更してください。

Sub Sample2()
    Dim i As Long, k As Long, lastRow As Long
    Dim str As String, c As Range
    Dim wS As Worksheet, myAry As Variant, myFlg As Boolean
        Set wS = Worksheets("キーワード表")
        With Worksheets("集計")
            lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
                If lastRow > 1 Then
                    Range(.Cells(2, "C"), .Cells(lastRow, "C")).ClearContents
                End If
            For i = 2 To lastRow
                myFlg = False
                str = Replace(.Cells(i, "A"), "　", " ")
                If InStr(str, " ") > 0 Then
                    myAry = Split(str, " ")
                    For k = 0 To UBound(myAry)
                        Set c = wS.Cells.Find(what:=myAry(k), LookIn:=xlValues, lookat:=xlWhole)
                            If c Is Nothing Then
                                myFlg = True
                                Exit For
                            End If
                    Next k
                Else
                    Set c = wS.Cells.Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
                        If c Is Nothing Then
                            myFlg = True
                        End If
                End If
                If myFlg = True Then
                    .Cells(i, "C") = 1
                End If
            Next i
        End With
End Sub

※　データ内に、アルファベット・数値の全角などがあった場合はお望み通りにならなかったはずですので、
その辺を訂正してみました。m(_ _)m

tom04 · Answer

こんばんは！
標準モジュールです。

Sub Sample1()
    Dim i As Long, k As Long, lastRow As Long
    Dim cnt As Long, c As Range, str As String
    Dim wS As Worksheet, myAry As Variant
        Set wS = Worksheets("キーワード表")
        With Worksheets("集計")
            lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
                If lastRow > 1 Then
                    Range(.Cells(2, "C"), .Cells(lastRow, "C")).ClearContents
                End If
            For i = 2 To lastRow
                cnt = 0
                str = StrConv(.Cells(i, "A"), vbNarrow)
                If InStr(str, " ") > 0 Then
                    myAry = Split(str, " ")
                    For k = 0 To UBound(myAry)
                        Set c = wS.Cells.Find(what:=myAry(k), LookIn:=xlValues, lookat:=xlWhole)
                        If Not c Is Nothing Then
                            cnt = cnt + 1
                        End If
                    Next k
                    If cnt <> UBound(myAry) + 1 Then
                        .Cells(i, "C") = 1
                    End If
                Else
                    Set c = wS.Cells.Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
                    If c Is Nothing Then
                        .Cells(i, "C") = 1
                    End If
                End If
            Next i
        End With
End Sub

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

エクセルでキーワードの検索分析の方法２

＃７です

＃６です

＃５です

＃４です

＃３です

以下でどうなりますか

No.1です。

こんばんは！

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

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

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

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