オンライン健康相談、gooドクター

エクセルで、sheet1のA列に語句に対して、sheet2のキーワード表で一致した場合、
sheet2のキーワード表のA列の語を入れ込むマクロがあります。

サンプルを添付しました。
http://yahoo.jp/box/D5A4U9

そこで、sheet1で新しい語がある場合にB列の「新規語句」に”1”とでるようにしたいです。
サンプルのシートでいう 4行目の「りんご 青森」(りんごはあるけど青森がないので1)
5行目の「山梨 ぶどう 」(山梨もぶどうも存在する)ので1はなし)

11行目の「大阪 天丼」(天丼はあるけど、大阪ははないので1)

このような表をチェックできるようなマクロはないでしょうか。
前回に続いて同じ内容の質問をして申し訳ないのですが、わかる方教えていただけないでしょうか。

質問者からの補足コメント

  • つらい・・・

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


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

    No.3の回答に寄せられた補足コメントです。 補足日時:2015/06/16 13:23
  • つらい・・・

    標準モジュールに#3の内容で
    「リンゴ」、「リンゴ」「ル ルクチェ」を入れてやってみたのですが、
    キーワード表に存在しているのに「1」がでてしまいました。
    実際のファイルが以下です。

    http://yahoo.jp/box/BY-j7c

    No.4の回答に寄せられた補足コメントです。 補足日時:2015/06/17 12:00
  • つらい・・・

    大変失礼しました!!
    やりたいことが自分でまとめきれておりませんでした。

    やりたいことは、
    シート「集計」の B列 のものが「キーワード表」の分類であり、
    その分類の中での有り/無しは関係なく
    キーワード表自体に存在していない場合「1」をでるようにしたいです。

    再度やりたいことのシートを添付します。
    http://yahoo.jp/box/cnjlmA


    「りんご 青森」は青森がないので「1」でいいのですが、
    「山梨 ぶどう」は、山梨もぶどうもキーワード表の中に存在するので「1」ではない。

    あと「ル ルクチェ 山梨」はやはりむずかしいですかね?
    キーワード表に”ル ルクチェ”にしておいてチェックする方法とかないですか?

    長く付き合わせてしまい申し訳ございません。

    No.5の回答に寄せられた補足コメントです。 補足日時:2015/06/17 15:18
  • どう思う?

    すばらしいです!!!まさに思っていたことができました。

    重ね重ね申し訳ないのですが、
    集計シートの B列 C列を変えたい場合どうすればいいでしょうか・・・

    サンプル
    http://yahoo.jp/box/rJDuLc

    No.6の回答に寄せられた補足コメントです。 補足日時:2015/06/18 15:37
  • どう思う?

    ありがとうございます!しばらく使ってみてまったく問題なくできました。
    できるかどうかなのですが、
    下記のように順番がばらばらなときでも、分類を同じ並びにすることってできますかね?
    ①りんご 大 ⇒くだもの,サイズ
    ②大 りんご ⇒サイズ,くだもの

    サンプル↓
    http://yahoo.jp/box/VabLfb

    No.7の回答に寄せられた補足コメントです。 補足日時:2015/06/23 13:52
gooドクター

A 回答 (8件)

#7です


    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

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

  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
    • good
    • 0
この回答へのお礼

助かりました。これで膨大なキーワードの分析ができそうです!

お礼日時:2015/06/29 14:12

#6です



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

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

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

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

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

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

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

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

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


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


余談)

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

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

と分けて設定すればよいです。
この回答への補足あり
    • good
    • 0

#5です



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

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

Dictionary は1段構成の dic / dicW の2つを使用
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
この回答への補足あり
    • good
    • 0

#4です



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

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

16行目~19行目の B列に「くだもの」を設定して確認してみてください。
この際、「ル ルクチェ」に関しては、
「ル」と「ルクチェ」に区切って確認しているので 1 になります。
これを解釈するために、以下の★部分(2行)を追加してみてください。
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列は新規語句のようでしたが、
サンプルでは検索となっており、
これを分類と解釈し、その中での語チェックをしたものです。
この回答への補足あり
    • good
    • 0

#3です



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

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

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

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

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

これも問題ないと思いますが・・・
(どこが半角かわかりませんけど)


※ 私が確認した手順( Vista + 2007 )

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

以下でどうなりますか



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

は、同じものとして判別します
サンプルファイルの16行目は 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


※ 記述についての説明が必要なら補足ください
この回答への補足あり
    • good
    • 0

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
    • good
    • 0

こんばんは!


標準モジュールです。

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
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

gooドクター

人気Q&Aランキング