エクセルで組み合わせの集計方法

質問

またお世話になります。

例えば下記のようなデータがあるとします。

　｜Ｂ｜Ｃ｜Ｄ｜Ｅ｜
----------------------
１｜ａ｜ｂ｜ｃ｜ｅ｜
----------------------
２｜ｂ｜ｃ｜ａ｜ｅ｜
----------------------
３｜ａ｜ｅ｜ｆ｜ｇ｜
----------------------
４｜ｂ｜ｆ｜ｅ｜ａ｜
----------------------
　　　　　：
　　　　　：
（データは下へ追加されていきます）

上記のデータを行毎に調べて、各値と最も多い組み合わせを調べるにはどうしたらよいでしょうか？
例えば「ａ」と最も多く組み合わせているのは、「ｅ」となります。
あた「ｂ」と多く組み合わせているのは、「ｅ」となります。

このように各入力値ごとに、最も多く組み合わせているものを抽出するにはどのようにしたら良いでしょうか。
実際には文字ではなく数字を入力しています。

私が考えている方法は、すべての文字に対しての組み合わせ表を作成して、そこから最も多いそれぞれの組み合わせを求めるということですが、これではかなりの量の組み合わせデータを作成しなければならないことになります。

もっと簡単にできる方法はないかと思い、こちらに質問させて頂きました。

とても難しいような気がしますが、アドバイスをよろしく御願いします。

（エクセル98を使用しております。）

回答No.4

sakenomo

"組み合わせ"と考えると大変ですが、調べたい値、たとえば１なら、1を含む各行の中で、1の次に多くある値を調べればいいわけです。なんだかNo.545271のご質問の応用編のようですね。

以下のマクロは、各行中に重複する値は無い事が前提です。1-2と2-1の扱いですが、両方表示します。データを新しいシートのA1にかかるようにコピーして使ってください。
ちょっと長いですが、もう眠いのでNo.545271の関数を少し変えて使いました。

Sub test3()
Dim c As Range, dc As Range, i As Integer, b As Byte, mc As Byte
Dim ip As Integer, nb As Byte, ia As Integer, ei As Integer
Dim myR As Range

Set dc = Range("A1").CurrentRegion
b = dc.Columns.Count
Columns(b + 2).Value = ""
For Each c In dc
If c.Value <> "" Then
i = 1
Do
With Cells(i, b + 2)
If .Value = "" And .Value <> c.Value Then
Cells(i, b + 2).Value = c.Value
ip = ip + 1
Exit Do
Else
If .Value = c.Value Then Exit Do
End If
End With
i = i + 1
Loop
End If
Next c
Set myR = dc.Offset(0, b + 4)
myR.Value = dc.Value
For ia = 1 To ip
ei = 0
For i = 1 To myR.Rows.Count
With myR.Rows(i)
For nb = 1 To b
If .Columns(nb).Value = Cells(ia, b + 2).Value Then
.Columns(nb).Value = ""
ei = ei + 1
mc = 1
Exit For
End If
Next nb
If mc = 0 Then .Value = ""
mc = 0
End With
Next i
If ei = 1 Then
Cells(ia, b + 3).Value = ""
Else
Cells(ia, b + 3).Value = InLarge2(myR, Cells(ia, b + 2).Text)
End If
myR.Value = dc.Value
Next ia
myR.Value = ""
Cells(1, b + 3).CurrentRegion.Sort Key1:=Cells(1, b + 3), Order1:=xlDescending, Header:=xlNo, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub

Function InLarge2(データ As Range, myS As String) As String
Dim moji() As String, Cosu() As Integer, i As Integer
Dim myRange As Range, Most As String, ip As Integer

ReDim moji(データ.Count)
ReDim Cosu(データ.Count)
For Each myRange In データ
If myRange.Text <> "" Then
Do
If moji(i) = myRange.Text Then
Cosu(i) = Cosu(i) + 1
Exit Do
Else
If moji(i) = "" Then
moji(i) = myRange.Text
Cosu(i) = 1
Exit Do
End If
i = i + 1
End If
Loop
i = 0
End If
Next myRange
i = 1
Do
If Cosu(ip) <= Cosu(i) Then
If Cosu(ip) = Cosu(i) Then
Most = Most & "," & moji(i)
Else
ip = i
Most = ""
End If
End If
i = i + 1
Loop Until Cosu(i - 1) = 0
InLarge2 = Cosu(ip) & "組　" & myS & "と" & moji(ip) & Most
End Function

回答No.3

papayuka

こんにちは。
難しいですね。
実際は数字でサンプルが文字と言うのもちょっと質問のされかたとしてはどうかと。。
直接回答とはいきませんが、参考になればと思います。

下記はタイトルを含まないデータがＡ列からＤ列に入っている想定で書いてます。
Ｆ列～Ｇ列にデータを出します。

テストではＡ1～Ｄ４に下記データだけを入れたシートを用意して行ないました。

A列　B列　C列　D列
a　　　b　　　c　　　e
b　　　c　　　a　　　e
a　　　e　　　f　　　g
b　　　f　　　e　　　a

必ずテスト環境で試して下さい。

Sub aa()
Const dRow = 6
Dim LRow As Long, pRow As Long, stCol As Integer
Dim mgCol As Integer, maxCol As Integer

LRow = Range("A65536").End(xlUp).Row
For i = 1 To LRow
　　Rows(i).Sort key1:=Range("A" & i), Order1:=xlAscending, _
　　Header:=xlNo, Orientation:=xlLeftToRight
Next i
Cells(1, dRow) = "データ"
pRow = 2: maxCol = 4
For i = 1 To LRow
　stCol = 1: mgCol = 2
　Do While stCol <= maxCol - 1
　　Do While mgCol <= maxCol
　　　Cells(pRow, 6) = Cells(i, stCol) & Cells(i, mgCol)
　　　　mgCol = mgCol + 1: pRow = pRow + 1
　　Loop
　　stCol = stCol + 1: mgCol = stCol + 1
　Loop
Next i
Columns(dRow).Sort key1:=Cells(1, dRow), Order1:=xlAscending, _
　　　　　　　　　 Header:=xlYes, Orientation:=xlTopToBottom
Application.DisplayAlerts = False
Cells(1, dRow).CurrentRegion.Subtotal GroupBy:=1, _
　　　　　Function:=xlCount, TotalList:=Array(1), Replace:=True
Application.DisplayAlerts = True
Columns(dRow).EntireColumn.AutoFit
ActiveSheet.Outline.ShowLevels RowLevels:=2
End Sub

回答No.2

imogasi

＃１の者です。
＞（１）実際に試してみましたが、結果がセルに表示されませんでした。 ん～、難しいかな。。。
誤解されたようです。セルに本問の結果をセットする積もりでコーディングしてませんから。Ａ１：Ｄ４にＡ，Ｂ，Ｃ，Ｄが入っているとして、画面にＡ－Ｂ，Ａ－Ｃ，Ａ－Ｄ，Ｂ－Ｃ，Ｂ－Ｄ，Ｃ－Ｄを表示するもので、１行の組み合わせはこれで良いですねと言う小手調べの、テスト的な部分的コーディグです。お望みのセルに結果を出すコーディングはもっとずっと行数が多くなります。
＞（２）COUNTIF関数を使用していろいとと試しているのですが
全ての組み合わせを人間が拾い上げ、その組み合わせが
表中に何件あるかは関数で出せるでしょう。しかし七面倒
で私ならやる気がしません。
（３）本件はＶＢＡでないと出来ないと思います。しかしＶＢＡのコーディングを入れても、簡単でなくて、（１）のことからして、判っていただけるか心配です。

回答No.1

imogasi

データ入力列がＢ，Ｃ，Ｄ，Ｅの４列で終わりですか。
これは例示であって、実際ではもっと沢山列があるのですか。ご存知のように組み合わせの数は、要素が増えると直ぐ大きくなります。それで難しくなりそうです。
多分操作や関数では不可能でＶＢＡが必要になるでしょう。コーディグを希望しますか。ロジックは
（１）各行について「各列の文（数）字の組み合わせ表（Ｔ）を作成して」
（２）既存の表（Ｔ）の中にその組み合わせがあるか探して
（３）あればその組み合わせの件数を＋１し、
（４）最終行まで繰り返して
（５）件数列で降順にソートします。一番多い組み合わせは第１行目に出ます。
（６）うるさいのは（２）で、Ａ－ＢもＢ－Ａも同じと見なす必要があります。
各行の組み合わせは、第１行にＡ，Ｂ，Ｃ．Ｄが入っていてこの１行だけ組み合わせを見る例として
Sub test04()
i = 1
For k = 1 To 3
For j = k + 1 To 4
MsgBox Cells(i, k) & "-" & Cells(i, j) '確認用
Next j
Next k
End Sub
で良いと思います。これを全行について行い、同じ組み合わせが既にないかチェックすれば良いでしょう。上記（６）に注意して。

お礼

御回答ありがとうございます。

実際に試してみましたが、結果がセルに表示されませんでした。
ん～、難しいかな。。。

考えてみたのですが、例のデータを参考にすると、
B列とC列を検索対象にして、その中で「B=C」の条件を満たすものだけをカウントしていくというのはどうでしょう？
COUNTIF関数を使用していろいとと試しているのですが、なぜか上手くいきません（ー＿ー；

でもかなりの労力を要するには変わりませんが。。。

もうちょっと、試行錯誤してみます。