質問: エクセルでキーワードの検索分析の方法2 エクセルで、sheet1のa列に語句に対して、sheet2のキーワード表で一致した場合、 sheet2のキーワード表のa列の語を入れ込むマクロがあります。 サンプルを添付しました。 http://yahoo.jp/box/d5a4u9 そこで、sheet1で新しい語がある場合にb列の「新規語句」に”1”とでるようにしたいです。 サンプルのシートでいう 4行目の「りんご 青森」(りんごはあるけど青森がないので1) 5行目の「山梨 ぶどう 」(山梨もぶどうも存在する)ので1はなし) 11行目の「大阪 天丼」(天丼はあるけど、大阪ははないので1) このような表をチェックできるようなマクロはないでしょうか。 前回に続いて同じ内容の質問をして申し訳ないのですが、わかる方教えていただけないでしょうか。
回答: #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