■近似している文字列を抽出したい

エクセル内に数万件のレコードが書き込まれています。
登録されているデータの品質をチェックしたいため、
特定の列を参照し、類似しているデータは一括で抽出したいと考えています。

エクセルの関数だけに限った際、
下記のようなやり方があるかと思いますが、
一括で抽出することができないためお知恵をいただきたい所存です。

現在のチェック方法
(1)B2のリンゴをA1にコピーし、C列はA1とB列の文字列の適合率を表示する。
(2)C列の適合率が高いもの（仮に90%以上適合した文字列）を目検でチェック
(3)B3以降をA1に順次コピーして(1)～(2)のチェックを行う
　　　　　　|A列　　　|B列　　　|C列
1　　　　　|リンゴ　|　　　　　　 |
2　　　　　|　　　　　|リンゴ　　　|100%
3　　　　　|　　　　　|すいか　　|0%
4　　　　　|　　　　　|もも　　　　|0%
5　　　　　|　　　　　|すもも　　　|0%
6　　　　　|　　　　　|メロン　　　|33%
7　　　　　|　　　　　|生ハム　　|0%
8　　　　　|　　　　　|おリンゴ　|100%


■ご質問させていただく内容
・近似した文字列の適合率を一括で調べるもしくは抽出するツールをご存知でしょうか？
・もしくは、上記に記載した内容をマクロで組むことができるでしょうか？
例えば以下のような流れです。
※上図を参考に説明
(1)Sheet1のB2の文字列の適合率をB2:B8まで順次計算してC列に代入
(2)Sheet1のC列を参照し、B2の行以外で適合率が90%以上の場合、Sheet2のA列に代入
(3)B3～B8まで(1)～(2)の処理を繰り替えす。
※参考になるサイトやプログラムなどをご教示いただければ幸いです。

よろしくお願い致します。

No.1 回答者： mana011210 回答日時： 2013/08/23 17:48

ドラえもんでしょう？

簡単だよ。

抽出ロボット
これがあれば何でも抽出が出来るんだ（笑）

No.2 回答者： mt2008 回答日時： 2013/08/23 18:24

C2に↓の式を入れ、表示書式をパーセンテージにして下方向へコピー

=COUNT(INDEX(FIND(MID(B2,ROW(INDIRECT("1:"&LEN(B2))),1),A$1),0))/LEN(A$1)

これでC列のデータは出来るので、B:C列をSheet2にコピーしてフィルタで90%以上の物だけ表示しましょう。
ただ、この式が数万個あると相当重くなりそうですから、最初からVBAの方が良いかなぁ……。

この回答へのお礼

ご教示くださいましてありがとうございます。
確かに処理が非常に重いようです。

ベストアンサーはVBAのプログラムをご提供いただけたtom04様とさせていただきます。

またよろしくお願いいたします。

お礼日時：2013/08/26 12:42

No.3 回答者： f_a_007 回答日時： 2013/08/23 19:03

【仕様設計】

検索準備:[済]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
チェックするデータ:[リンゴ______]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
類似データ一覧　[2/52300]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
おリンゴ　　|100%
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
メロン　　　|_33%
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
　　　　　　|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

例えば、[チェックするデータ]に'リンゴ'と入力すると、[類似データ一覧]に類似度を計算し高い順に表示される。こういう仕様設計が先かと思いますよ。

【大まかにアプリケーションの流れを決める】

次に、大まかにアプリケーションの流れを決めます。

１、数万件のデータを変数に取り込む。
　↓
２、チェックするデータが入力されたら次の処理を行う。

　２．１、数万件のデータとの照合を行う。
　２．２、ヒットしたらデータ名と類似度を記憶する。
　２．３、記憶したデータを並び替える
　２．４、並び替えたデータを表示する。
　２．５、ヒット総数を更新する。

【アプリケーションを書く情報を収集する】

・[検索準備]ボタンを押すと対象データを変数に取り込むには？
・取り込んだら[未]を[済]に書き換えるには？
・類似度算出アルゴリズムを書くには？
・・・・・
・・・・・

このように、開発プロセスを細かくWordkか何かで書くこと。そして、徐々に、最終コードへと接近することです。

祈、成功！

この回答へのお礼

ご教示くださいましてありがとうございます。
作成手順など、情報をご提供いただけるだけでも助かります。

またよろしくお願いいたします。

お礼日時：2013/08/26 12:40

No.4 ベストアンサー 回答者： tom04 回答日時： 2013/08/23 22:41

こんばんは！

ExcelでVBAの一例です。

↓の画像で左側がSheet1・右側がSheet2とします。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, k As Long, cnt As Long, str As String, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
i = wS2.Cells(Rows.Count, "A").End(xlUp).Row
If i > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(i, "C")).ClearContents
End If
wS2.Range("B:B").Style = "Percent" '←Sheet2のB列を％表示にしている場合は不要
With wS1
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
.Range("A1") = .Cells(i, "B")
For j = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
If InStr(.Cells(j, "B"), .Range("A1")) > 0 Then
.Cells(j, "C") = 1
Else
For k = 1 To Len(.Range("A1"))
str = Mid(.Range("A1"), k, 1)
If InStr(.Cells(j, "B"), str) > 0 Then
cnt = cnt + 1
End If
Next k
.Cells(j, "C") = cnt / Len(.Range("A1"))
cnt = 0
End If
If .Range("A1") <> .Cells(j, "B") And .Cells(j, "C") >= 0.9 Then
With wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = wS1.Cells(j, "B")
.Offset(, 1) = wS1.Cells(j, "C")
.Offset(, 2) = wS1.Range("A1")
End With
End If
Next j
Next i
.Range("C:C").ClearContents
End With
End Sub 'この行まで

※　余計なお世話かもしれませんが、Sheet2のC列にはSheet1のA1セルのデータの場合で
B列にはそれに対する割合を表示させています。
Sheet2の2行目を説明すると
A1セルが「リンゴ」の時に「おリンゴ」が100％になります

同様に3行目はSheet1のA1セルが「もも」の時に「すもも」が100％
というコトになります。
（Sheet1のC列データは最終的には消しています）

外していたらごめんなさいね。m（_ _）m

この回答へのお礼

プログラム自体、細かいところまでご提供くださいましてありがとうございました。
やりたいこと自体、完璧です。


重ねて御礼申し上げます。

お礼日時：2013/08/26 12:37