エクセル 異なる列から部分的に同じ値を抽出する方法

掲題の件について教えてください。
Excel初心者です。

→→A列→→→→→→→→B列
1行 名古屋クリニック→→名古屋病院
2行 瑞穂歯科→→→→→→瑞穂専門学校

という表があった時、(各行ごとに)A列とB列に共通する『名古屋』、『瑞穂』を抽出する関数を教えていただきたくお願いいたします。
＊値を指定する作業セルは使わない。(約4万行に異なる会社名が羅列してあり、その旧名称と新名称が対応しているかどうかをチェックする作業に使用するため)

説明不足な部分すらも分からないので、補足で質問していただければ幸いです。
よろしくお願いいたします。

No.1 ベストアンサー 回答者： kagakusuki 回答日時： 2013/12/19 12:32

　共通の文字列を抽出した結果が、「旧名称と新名称が対応しているかどうかをチェックする作業」に、果たしてどれほど役に立つのかは疑問が残るところですが、取り敢えずは、以下の様なVBAのマクロを使ってみられては如何でしょうか？

　A列に入力されている文字列とB列に入力されている文字列との間で、共通している文字列が1つ以上あった場合、その中から最も長い文字列を抽出して、C列に表示させるというマクロです。
　[註]マクロを実行される際には、念のために元のファイルをコピーしたファイルを使って抽出する事を御勧め致します。

Sub Macro()

Dim fr, lr, i, j, k, l, lm, p As Long
Dim s, sa, sb As String

fr = 1 '実際のデータが入力されている1番上の行の行番号
If Application.WorksheetFunction.CountIf(Range("A" & fr & ":A" & Columns.Rows.Count), "*?") = 0 Then Exit Sub
lr = Application.WorksheetFunction.Match(Chr(1), Columns("A:A"), -1)
For i = fr To lr
sa = Range("A" & i).Value
sb = Range("B" & i).Value
If sa = "" Or sb = "" Then GoTo Label1:
lm = Len(Range("A" & i).Value)
l = 0
p = 0
For j = 1 To lm
For k = 1 To lm - j + 1
s = Mid(sa, j, k)
If InStr(sb, s) > 0 And k > l Then
p = j
l = k
End If
Next k
Next j
If p * l > 0 Then Range("C" & i).Value = Mid(sa, p, l)
Label1:
Next i

End Sub


　尚、もしも、1行目が項目名の入力欄などとして使用されていて、共通部分を抽出しなければならないデータが実際に入力されているのは、例えば2行目からであるなどという場合には、6行目の所にある

fr = 1

という記述を、

fr = 2

の様に変更して下さい。
　それから、もしVBAの使い方が判らない場合には、以下のURLのページを参考にして下さい。

【参考URL】
　よねさんのWordとExcelの小部屋 > ExcelVBA入門 > VBAコード(プログラム)の記述と実行の手順
　　http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/v …

この回答へのお礼

早速のご回答ありがとうございます！
VBAから調べて実践してみます！笑
共通する最も長い文字列を抽出できるとのことなので、私が今回求めていた処理ができると思います！
ありがとうございました！！！

お礼日時：2013/12/19 22:37