商品情報からマトリクス作成

質問

（シート１）
A | B | C | D |・・・・・・|AI　A～最大AIまで
1|MM01|
2|BB01|BB03|LL01|BB01|
3|LL01|BB02|
4|MM03|LL01|LL01|
5|BB03|
・
・
・
10000
一万行まで

シート１の行に商品（MM01など、全３５品目）がある場合、
シート２へ商品の項目に対応して１を、
シート１に商品がなければ、
シート２へ0を入力する。

シート１の同じ行に複数の同製品(行番号２の場合、BB1)があっても、
シート２へは１を入力する。

（シート２）
A B C D E F G H ・・・
1|MM01|MM02|MM03|BB01|BB02|BB03|LL01|LL02|・・・全３５商品(一行目の商品リストはすでにある)
2|1 |0 |0 |0 |0 |0 |0 |0 |・・・
3|0 |0 |0 |1 |0 |1 |1 |0 |・・・
4|0 |0 |0 |0 |1 |0 |1 |0 |・・・
5|0 |0 |1 |0 |0 |0 |1 |0 |・・・
6|0 |0 |0 |0 |0 |1 |0 |0 |・・・
・
・
・

このようにシート１からシート２へ
マトリクスを作るVBAをご伝授ください。
エクセル以外でも、SPSSやRでこのようなマトリクスを作成する
方法をご存知でしたらご伝授ください。
よろしくお願いします。

回答No.2

KenKen_SP · ベストアンサー

こんにちは。

VBA が良いのでしょうか？

Sheet2!A2 数式　=IF(SUMPRODUCT((Sheet1!1:1=A$1)*1),1,0)

あとは、作表する範囲にコピペするだけで関数でできますよ。

#1 で VBA による模範的な回答が既にあるのですが、別案として書くと
ワークシートの計算機能を活用する方法があります。上記数式の応用
ですね。

Sub Sample()

　　Dim nn As Long
　　nn = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
　　With Worksheets("Sheet2").Range("A2:H2").Resize(nn)
　　　　.Formula = "=IF(SUMPRODUCT((Sheet1!1:1=A$1)*1),1,0)"
　　　　.Value = .Value ' // 値にしたい場合
　　End With

End Sub

お礼

無事できました。
関数を使ってこんなに簡単にできるとは。
私の調査不足でした；；
ありがとうございました！

回答No.3

imogasi

コードはより簡単に出来ると思う。
Sheet2の第１行に
MM01 MM02 MM03 BB01 BB02 BB03 LL01
があるらしいからありがたい。
例データ　Sheet1
MM01
BB01 BB03 LL01 BB01
LL01 BB02
MM03 LL01 LL01
BB03
ーーー
コード
Sub test01()
d = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
For i = 1 To d
c = Worksheets("Sheet1").Range("IV" & i).End(xlToLeft).Column
For j = 1 To c
x = Application.WorksheetFunction.Match(Worksheets("Sheet1").Cells(i, j), Worksheets("Sheet2").Range("A1:IV1"), 0)
Worksheets("Sheet2").Cells(i + 1, x) = 1
Next j
Next i
End Sub
ーーー
結果
MM01 MM02 MM03 BB01 BB02 BB03 LL01
1
- - - 1 1 1
- - - - 1 - 1
- - 1 - - 1
- - - - - 1
ーーーーーーーーーーーーーー
ーは（OKWAVEで左詰めされないよう）スペースの代わり。
該当なしは、０にも出来るが、見やすいこともアリ、空白のままにとりあえず。

お礼

ありがとうございました！
とりあえずMatch関数使いこなせるよう頑張ります。

回答No.1

n-jun

Sub　try()
　Dim　DIC　As　Object
　Dim　i　As　Long,　j　As　Long
　Dim　m　As　Long
　Dim　v,　w,　x

　Set　DIC　=　CreateObject("Scripting.Dictionary")

　With　Worksheets("Sheet2")
　　　　　　v　=　.Range(.Range("A1"),　.Cells(1,　Columns.Count).End(xlToLeft))
　　　　　　For　m　=　1　To　UBound(v,　2)
　　　　　　　　　　DIC(v(1,　m))　=　m
　　　　　　Next
　End　With

　With　Worksheets("Sheet1")
　　　　　　w　=　.UsedRange
　　　　　　ReDim　x(1　To　UBound(w,　1),　1　To　UBound(v,　2))
　　　　　　For　i　=　1　To　UBound(w,　1)
　　　　　　　　　　For　j　=　1　To　UBound(w,　2)
　　　　　　　　　　　　　　If　DIC.exists(w(i,　j))　Then
　　　　　　　　　　　　　　　　　x(i,　DIC(w(i,　j)))　=　1
　　　　　　　　　　　　　　End　If
　　　　　　　　　　Next
　　　　　　Next
　End　With

　With　Worksheets("Sheet2")
　　　　　　.Range("A2").Resize(UBound(w,　1),　UBound(v,　2)).Value　=　x
　　　　　　.Range("A1").CurrentRegion.SpecialCells(xlCellTypeBlanks).Value　=　0
　End　With
　Set　DIC　=　Nothing
　Erase　v,　w,　x
End　Sub
ご参考程度に。

お礼

ちと理解が乏しいですが、がんばって勉強します。
ありがとうございました！