excelで購入データから商品の組み合わせを集計

Question

添付の【表1】のように、購入者が購入した商品が一個一行でまとめられた購入データがあります。

購入者がどのような組み合わせで商品を購入しているかを把握するために、
【表2】のように、同一購入者が併買している組み合わせの数をエクセルでカウントしたいと考えています。

excelの関数、またはピボットテーブル等で集計する方法があれば教えていただけないでしょうか。
併買を集計する目的にかなうのであれば、【表2】の表を変更いただいても構いません。

どうかよろしくお願いいします。

MackyNo1 · Accepted Answer

例示のデータを集計するなら、ピボットテーブルと関数の合わせ技で実行することがすることができます。

ご使用のエクセルのバージョンが明記されていませんので、例えばExcel2007で説明すると、準備として元データをホームタブの「テーブルとして書式設定」しておきます（これでデータ追加にピボットテーブルが自動的に対応します）。
次に、挿入タブの「ピボットテーブル」から、行ラベルに「番号」、列ラベルとΣ値に「商品」をドラッグしていったんピボットテーブルを作成し、テーブル上を右クリックから「ピボットテーブルオプション」の集計とフィルタタブから行と列の総計を表示するのチェックを外します（添付画像のようなテーブルになります）。
次に添付画像のH2セルに列ラベルの商品名をコピー貼り付けし、縦方向にもG3セル以下に形式を選択して貼り付けで「行と列を入れ替える」で貼り付けます（この商品名は関数でも表示させることができます）。
この表のH3セルに以下の式を入力し、右方向および下方向にオートフィルし、同じ名前が交差する部分の数式を削除します（または斜め罫線を入れる）。

=SUMPRODUCT(INDEX($B$5:$D$100,,MATCH(H$2,$B$4:$D$4))*INDEX($B$5:$D$100,,MATCH($G3,$B$4:$D$4)))

データ追加した場合は、ピボットテーブルを右クリックから「更新」すれば新規データの組み合わせが表示されます。

ただし、新しい商品を追加した場合は、その商品名が自動追加されませんので、自動的に対応したい場合は商品も関数で表示させることになりますが計算負荷が大きくなるのであまりお勧めできません。

MarcoRossiItaly · Answer

No.4 です。No.4 のコード中、「For j = 2 To ter2」の次にある「With s1」と、下から 4 行目の「End With」は、消し忘れです。無意味なので、消してください。失礼しました。

MarcoRossiItaly · Answer

マクロの力技で計算し、挿入したシートに答えを出す例。標準モジュールにコピペ。思いのほか手間でしたね。

'「購入者番号」が A 列にある場合のコード
'集計する表のあるシートをアクティブにしてから実行

Sub RoundRobinTable()

Dim s1 As Worksheet, s2 As Worksheet
Const ini As Long = 4    '集計する対象範囲（見出しを除く部分）の先頭の行番号
Dim ter1 As Long, ter2 As Long, i As Long, j As Long, k As Long

Set s1 = ActiveSheet
ter1 = Cells(Rows.Count, "a").End(xlUp).Row

Worksheets.Add after:=s1
Set s2 = ActiveSheet

With s1
　　.Rows(ini).Insert
　　.Cells(ini, "b").Value = "title"
　　.Range(.Cells(ini, "b"), .Cells(ter1 + 1, "b")).AdvancedFilter _
　　Action:=xlFilterCopy, copytorange:=s2.Range("a1"), unique:=True
　　.Rows(ini).Delete
End With

Range("a1").Clear
ter2 = Cells(Rows.Count, "a").End(xlUp).Row
Range(Range("b1"), Cells(1, ter2)) = WorksheetFunction.Transpose(Range(Range("a2"), Cells(ter2, "a")))
Range(Range("a1"), Cells(ter2, ter2)).Borders.LineStyle = xlContinuous
For i = 1 To ter2
　　Cells(i, i).Borders(xlDiagonalDown).LineStyle = xlContinuous
Next i

For i = 2 To ter2
　　For j = 2 To ter2
　　　　With s1
　　　　　　If i <> j Then
　　　　　　　　For k = ini To ter1
　　　　　　　　　　If WorksheetFunction.CountIf(s1.Range(s1.Cells(ini, "a"), s1.Cells(k, "a")), s1.Cells(k, "a").Value) < 2 And _
　　　　　　　　　　WorksheetFunction.CountIfs(s1.Columns("a"), s1.Cells(k, "a").Value, s1.Columns("b"), s2.Cells(i, "a").Value) Then
　　　　　　　　　　　　s2.Cells(i, j).Value = s2.Cells(i, j).Value + WorksheetFunction.CountIfs( _
　　　　　　　　　　　　s1.Columns("a"), s1.Cells(k, "a").Value, s1.Columns("b"), s2.Cells(1, j).Value)
　　　　　　　　　　Else
　　　　　　　　　　　　With s2.Cells(i, j)
　　　　　　　　　　　　　　If .Value = "" Then .Value = 0
　　　　　　　　　　　　End With
　　　　　　　　　　End If
　　　　　　　　Next k
　　　　　　End If
　　　　End With
　　Next j
Next i

End Sub

mitarashi · Answer

>関数、またはピボットテーブル
ではなくなってしまいますが．．．
久しぶりにまじめにループを回してみました。三歩歩くと自分でも分からなくなるかもしれませんので、ご参考までに。
表1が1番目のシートのA1から置いてあるとして、2番目のシートに分類します。表１は購入者番号でソーティングされているものとします。
ちょっとすっきりしない部分もありますが、動いている様にみえます。
'連想配列
Dim myDic As Object

Sub test()
  Dim buf As Variant '元データを入れる配列
  Dim buf2() As Variant '購入者番号が同じデータ群を入れる配列
  Dim i As Long, j As Long
  Dim dicKeys As Variant
  Dim myKey As String
  
  'ユニークな種類取り出し
  Set myDic = CreateObject("Scripting.Dictionary")
  With Sheets(1)
    buf = .Range(.Range("A2"), .Range("B" & .Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(buf, 1)
    If Not myDic.exists(buf(i, 2)) Then myDic.Add buf(i, 2), myDic.Count + 1
  Next i
  dicKeys = myDic.keys
  'Sheets(2)へ見出し行、列として配置
  With Sheets(2)
    .Cells.ClearContents
    .Range(.Cells(1, 2), .Cells(1, myDic.Count + 1)).Value = dicKeys
    .Range(.Cells(2, 1), .Cells(myDic.Count + 1, 1)).Value = Application.Transpose(dicKeys)
  End With
  
  j = 1
  For i = 1 To UBound(buf, 1)
     If j = 1 Then
      myKey = buf(i, 1)
      ReDim buf2(1 To 1)
      buf2(1) = buf(i, 2)
      j = j + 1
    Else
      If buf(i, 1) = myKey Then
        ReDim Preserve buf2(1 To j)
        buf2(j) = buf(i, 2)
        j = j + 1
      Else
        '分配ルーチンに配列を渡す
        If UBound(buf2) > 1 Then distribute buf2
        j = 1
        myKey = buf(i, 1)
        ReDim buf2(1 To 1)
        buf2(1) = buf(i, 2)
        j = j + 1
      End If
    End If
  Next i
  If UBound(buf2) > 1 Then distribute buf2
End Sub

Sub distribute(myArray() As Variant)
  Dim i As Long, j As Long
  Dim destCell As Range
  
  For i = 1 To UBound(myArray)
    For j = 1 To UBound(myArray)
     If i <> j Then
        With Sheets(2)
          Set destCell = .Cells(myDic(myArray(i)) + 1, myDic(myArray(j)) + 1)
          destCell.Value = destCell.Value + 1
        End With
     End If
    Next j
  Next i
End Sub

bunjii · Answer

>併買を集計する目的にかなうのであれば、【表2】の表を変更いただいても構いません。
【表1】と【表2】を同じシートに作成しました。
併買の組み合わせが3つであり途中集計表の下に図形化しました。

途中集計はE2セルに次の式をセットして右および下へオートフィルでコピーします。
=COUNTIFS($A$2:$A$11,$D2,$B$2:$B$11,E$1)

併買のチェックはCOUNTIFS関数を使いました。

=COUNTIFS(E2:E7,1,F2:F7,1)
=COUNTIFS(F2:F7,1,G2:G7,1)
=COUNTIFS(E2:E7,1,G2:G7,1)

貼付画像で確認してください。

excelで購入データから商品の組み合わせを集計

例示のデータを集計するなら、ピボットテーブルと関数の合わせ技で実行することがすることができます。

No.4 です。

マクロの力技で計算し、挿入したシートに答えを出す例。

>関数、またはピボットテーブル

>併買を集計する目的にかなうのであれば、【表2】の表を変更いただいても構いません。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング