エクセルで同行セル内の文字列のマッチ数

質問

■ABC（本番はABCDEFGH）セルに上記のようなスペースで区切られた文字列が入っています。

■要望
行単位でABCセルを比較してマッチする文字列の数をD列に表示したい。
数値の内容をE列に表示してどのキーワードで何文字ヒットしたか表示したい。
同じ行のセル同士でマッチ数を計測し、内容が近しいものを抽出したいと考えております。

■条件
同じセルに同じ文字が入っていた場合は１つと考える。
E列の表示方法は文字列ごとに次の列に表示してもよい。

回答No.3

tom04

こんばんは！
VBAになってしまいますが・・・
一例です。

Sheet1のデータをSheet2に表示するようにしてみました。
データはSheet1の1行目からあるとします。
尚、Sheet3を作業用のSheetとして使っていますので、Sheet3はまったく使用していないものにしてください。

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

Sub test() 'この行から
Dim i As Long, j As Long, k As Long, n As Long, m As Long
Dim cnt As Long, myRow As Long, myCol
Dim buf As String
Dim tmp, myArray
Dim wS1 As Worksheet, wS2 As Worksheet, ws3 As Worksheet
Set wS1 = Worksheets("Sheet1") '←「Sheet1」は実際のSheet名に！
Set wS2 = Worksheets("Sheet2") '←「Sheet2」も・・・
Set ws3 = Worksheets("Sheet3")

Application.ScreenUpdating = False
wS2.Cells.ClearContents
On Error Resume Next
For i = 1 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To wS1.Cells(i, Columns.Count).End(xlToLeft).Column
tmp = Replace(wS1.Cells(i, j), "　", " ")
If InStr(tmp, " ") > 0 Then
myArray = Split(tmp, " ")
For k = 0 To UBound(myArray)
If WorksheetFunction.CountIf(ws3.Columns(j), myArray(k)) = 0 Then
n = n + 1
ws3.Cells(n, j) = myArray(k)
End If
Next k
End If
n = 0

For myCol = 1 To ws3.Cells(i, Columns.Count).End(xlToLeft).Column
For myRow = 1 To ws3.Cells(Rows.Count, 1).End(xlUp).Row
For m = 1 To ws3.UsedRange.Columns.Count
buf = ws3.Cells(myRow, myCol)
If WorksheetFunction.CountIf(ws3.Columns(m), buf) Then
n = WorksheetFunction.Match(buf, ws3.Columns(m), False)
ws3.Cells(n, m).ClearContents
End If
Next m
If WorksheetFunction.CountIf(wS2.Rows(i), buf) = 0 Then
wS2.Cells(i, Columns.Count).End(xlToLeft).Offset(, 2) = buf
End If
Next myRow
ws3.Cells.ClearContents
Next myCol
Next j
Next i

For i = 1 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
For myCol = 3 To wS2.Cells(i, Columns.Count).End(xlToLeft).Column Step 2
cnt = 0
For j = 1 To wS1.Cells(i, Columns.Count).End(xlToLeft).Column
If InStr(wS1.Cells(i, j), wS2.Cells(i, myCol)) > 0 Then
cnt = cnt + 1
End If
Next j
If cnt > 1 Then
wS2.Cells(i, myCol - 1) = cnt
Else
wS2.Cells(i, myCol).ClearContents
End If
Next myCol
wS2.Cells(i, 1) = WorksheetFunction.Sum(wS2.Rows(i))
Next i
wS2.Columns.AutoFit
Application.ScreenUpdating = True
End Sub 'この行まで

こんな感じではどうでしょうか？

※　仮にSheet2に数式が入っている場合はマクロを実行するとすべて消えてしまいますので、
別Bookでマクロを試してみてください。m(_ _)m

回答No.2

kagakusuki

>
=IF(OR('Sheet42 (2)'!D1="",ISERROR(1/(COUNTIF('Sheet42 (2)'!$A1:$C1,LEFT("*"&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"*")>1))),"",LEFT("("&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"×"&COUNTIF('Sheet42 (2)'!$A1:$C1,LEFT("*"&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"*")&")")&C1

>の貼り付けでsheet3に＃REF!エラーが出てしまいます。

　申し訳御座いません。
　関数試作用に使用したシート（Sheet42、Sheet42 (2)、Sheet42 (3)）の方に入力されていた関数の方を、誤って、そのまま載せてしまいました。
　正しくは、「'Sheet42 (2)'!」の部分を「Sheet2!」に置き換えた

=IF(OR(Sheet2!D1="",ISERROR(1/(COUNTIF(Sheet2!$A1:$C1,LEFT("*"&Sheet2!D1,FIND(" ",Sheet2!D1&" "))&"*")>1))),"",LEFT("("&Sheet2!D1,FIND(" ",Sheet2!D1&" "))&"×"&COUNTIF(Sheet2!$A1:$C1,LEFT("*"&Sheet2!D1,FIND(" ",Sheet2!D1&" "))&"*")&")")&C1

という関数になります。

>sheet2の1行目は2度下の行にコピーするという指示内容ですが認識合っていますでしょうか。

　いいえ違います。
　2行目以下ですから、2行目から始めて、ずっと下の方の行にまで、同じ内容を貼り付ける、という意味です。
　A列～C列の表の「文字列入力欄」（表の枠線で囲まれている範囲）が例えば、A1～C99の範囲である場合には、D2～E99のセル範囲に、また、文字列入力欄がA1～C999の範囲である場合には、D2～E999のセル範囲に貼り付けて下さい。
　その際、D列のセルに貼り付けるのはD1セルに入力した関数で、E列のセルに貼り付けるのはE1セルに入力した関数となる様にして下さい。（但し、関数中における、セルの参照先を指定している部分は、貼り付けた行に合わせて自動的に修正されますが、その事自体は、それで構いません）

回答No.1

kagakusuki

今仮に、御質問の添付画像に写っているような表がSheet1上に存在するものとします。
　又、Sheet2とSheet3の2枚のシートを作業用シートとして使用するものとします。

　まず、Sheet2のA1セルに次の関数を入力して下さい。

=IF(TRIM(Sheet1!A1)="",""," "&SUBSTITUTE(Sheet1!A1,"　"," ")&" ")

　次に、Sheet2のA1セルをコピーして、Sheet2のB1～C3に貼り付けて下さい。
　次に、Sheet2のD1セルに次の関数を入力して下さい。

=TRIM($A1&" "&$B1&" "&$C1)
　次に、Sheet2のE1セルに次の関数を入力して下さい。

=IF(D1="","",TRIM(SUBSTITUTE(" "&SUBSTITUTE(D1," "," ")&" "," "&LEFT(D1,FIND(" ",D1&" "))," ")))

　次に、Sheet2のE1セルをコピーして、Sheet2のF1から右方向に向かって（野菜や果物の種類数を上回るのに十分な回数だけ）貼り付けて下さい。
　次に、Sheet2の1行目全体をコピーして、2行目以下に貼り付けて下さい。

　次に、Sheet3のB1セルに次の関数を入力して下さい。

=IF(OR('Sheet42 (2)'!D1="",ISERROR(1/(COUNTIF('Sheet42 (2)'!$A1:$C1,LEFT("*"&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"*")>1))),"",LEFT("("&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"×"&COUNTIF('Sheet42 (2)'!$A1:$C1,LEFT("*"&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"*")&")")&C1

　次に、Sheet3のB1セルをコピーして、Sheet3のC1から右方向に向かって（野菜や果物の種類数を上回るのに十分な回数だけ）貼り付けて下さい。
　次に、Sheet3のA1セルに次の関数を入力して下さい。

=IF($B1="","",LEN($B1)-LEN(SUBSTITUTE($B1,"×",)))

　次に、Sheet2の1行目全体をコピーして、2行目以下に貼り付けて下さい。

　次に、Sheet1のE1セルに次の関数を入力して下さい。

=Sheet3!$B1&""

　次に、Sheet1のD1セルに次の関数を入力して下さい。

=IF($E1="",IF(Sheet2!$D1="","",0),SUMPRODUCT((REPLACE(LEFT($E1,FIND(CHAR(1),SUBSTITUTE($E1&"(",")(",CHAR(1),ROW(INDIRECT("Z1:Z"&Sheet3!$A1))))-1),1,FIND(CHAR(1),SUBSTITUTE($E1,"×",CHAR(1),ROW(INDIRECT("Z1:Z"&Sheet3!$A1)))),))*1))

　次に、Sheet1のD1～E1の範囲をコピーして、同じ列の2行目以下に貼り付けて下さい。

　以上です。

お礼

早速の御回答有難うゴじます。

=IF(OR('Sheet42 (2)'!D1="",ISERROR(1/(COUNTIF('Sheet42 (2)'!$A1:$C1,LEFT("*"&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"*")>1))),"",LEFT("("&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"×"&COUNTIF('Sheet42 (2)'!$A1:$C1,LEFT("*"&'Sheet42 (2)'!D1,FIND(" ",'Sheet42 (2)'!D1&" "))&"*")&")")&C1

の貼り付けでsheet3に＃REF!エラーが出てしまいます。

また、sheet2の1行目は2度下の行にコピーするという指示内容ですが認識合っていますでしょうか。

そこはともかくご回答いただきましてありがとうございます。