共通の値をもつ座標の組み合わせについて

質問

左図のような表があるときに、共通の値"1"を持つ座標の組み合わせを右図のように表示できるVBAを作ることができないかということで考えているところです。

右図の説明をすると
２行目にある　1 2 5 7は
左図　（１行,２列）のところに1、（１行,５列）のところに1、（１行,７列）のところに1、（２行,５列）のところに1、（２行,７列）のところに1、（５行,７列）のところに1

というように 1 2 5 7　のどの組み合わせを選んでも必ず1がある組み合わせです。

以下右図３行目以降も同じような形で表示されています。

VBAに詳しい方からのお知恵を拝借することができれば幸いです。よろしくお願いします。

回答No.20

_Kyle · ベストアンサー

#11,13,15-19です。

>メモリ不足と表示されてしまいました。

やはり出ますか。(^^;;;;;;

60万件の書出しは可能ということなので
100万件でも通るかな？　と思ったのですが…。
安易に過ぎたようです。すみません。

----------------------

>例えば４GBなどメモリが増えれば

あまり詳しいほうではないので
（わたしが）誤解している可能性もありますが
おそらくPCの問題ではないと思います。

ハードウェアのスペックは、
もちろん処理速度には影響しますが、
Excelが「メモリ不足」エラーを吐く場合は
スペック不足というよりも
「Excelがアプリケーションとして
　想定・確保している分のメモリを使い切った」
という状況が多いようです。

変数のオーバフローみたいなニュアンスですね。

===============================================

さて。

とりあえず分割書き出しにしてみました。

Sample_18改の書出Ｐ(Sub Sample_d)を
以下のように差し替えてください。
　※書出Ｐの下の書出順調整Ｐ（Sub Sample_s2）はそのままです。

　・[書き出し単位]件ずつ書き出して
　・[折り返し単位]セットで折り返します。

例えば
　[書き出し単位]：10000
　[折り返し単位]：100
に設定した場合、
１万件×100セット＝100万件で折り返します。

20万件ずつ書き出して100万件で折り返すなら
　[書き出し単位]：200000
　[折り返し単位]：5
に設定してください。

一度に多くの行を書き出すほうが速く書き出せますが
多すぎると今度はメモリが足りなくなります。
一般に、速度とメモリの関係は
トレードオフになりますので、調整してみてください。

おそらくこれでいけると思いますが、
もし「書出し準備中」表示の段階でメモリ不足になる場合は
"お手上げ"ということでご容赦ください。　<(_ _)>

===============================================

'　 'ヒット-----
'　 rtCnt = rtCnt + 1
'　 rtAry(rtCnt) = rsAry
'　 If rtCnt Mod 500 = 1 Then
'　　 Application.StatusBar = rtCnt & " 件"
'　 End If
'
' End Sub

'-----↓サシカエ↓------------------------------------------
'書出Ｐ----------------------
Private Sub Sample_d(ByRef rtSht As Worksheet)

　'設定------------
　Const untCnt As Long = 10000　　 　'◆[書き出し単位]
　Const setCnt As Long = 100　　　 　'◆[折り返し単位]
　Const brdClr As Long = vbYellow 　'◆[境界塗潰し色] ^^;;

　'宣言------------
　Dim dpAry() As Variant
　Dim o2Ary() As Long
　Dim mxCnt　 As Long
　Dim tpTbl() As Boolean
　Dim mxRow　 As Long
　Dim i　　　 As Long
　Dim j　　　 As Long
　Dim k　　　 As Long
　Dim m　　　 As Long
　Dim n　　　 As Long

　'並び調整--------
　Application.StatusBar = "書き出し準備中：並び調整"
　ReDim tpTbl(rtCnt, tbSiz)
　mxCnt = 0
　For i = 1 To rtCnt
　　k = 0
　　rsAry = rtAry(i)
　　For j = 1 To tbSiz
　　　If rsAry(j) Then
　　　　k = k + 1
　　　　tpTbl(i, odAry(j)) = rsAry(j)
　　　End If
　　Next j
　　If mxCnt < k Then mxCnt = k
　Next i

　'出順調整--------
　Application.StatusBar = "書き出し準備中：出順調整"
　ReDim o2Ary(rtCnt)
　For i = 1 To rtCnt
　　o2Ary(i) = i
　Next i
　Call Sample_s2(1, 1, rtCnt, o2Ary, tpTbl)

　'書出------------
　Application.StatusBar = "書き出し中"
　Application.Calculation = xlCalculationManual
　Application.ScreenUpdating = False

　With rtSht
　　.Select
　　.Cells.Clear
　End With

　mxRow = untCnt
　If rtCnt < mxRow Then mxRow = rtCnt

　For m = 0 To (rtCnt - 1) \ mxRow
　　ReDim dpAry(mxRow, mxCnt)

　　For i = 1 To mxRow
　　　n = m * mxRow + i
　　　If n > rtCnt Then Exit For
　　　k = 0
　　　For j = 1 To tbSiz
　　　　If tpTbl(o2Ary(n), j) Then
　　　　　k = k + 1
　　　　　dpAry(i, k) = j
　　　　End If
　　　Next j
　　Next i

　　Application.StatusBar = _
　　　"書き出し中： " & _
　　　m + 1 & " ／" & (rtCnt - 1) \ mxRow + 1

　　rtSht.Cells(1, 1).Offset( _
　　　(m Mod setCnt) * untCnt, _
　　　(m \ setCnt) * (mxCnt + 1) _
　　　).Resize(mxRow, mxCnt).Value = dpAry

　　'◆境界列塗潰し
　　If m Mod setCnt = 0 Then
　　　rtSht.Columns((m / setCnt + 1) * (mxCnt + 1)) _
　　　　.Interior.Color = brdClr
　　End If

　Next m

　Application.Calculation = xlCalculationAutomatic

End Sub
'-----↑サシカエ↑------------------------------------------

''書出順調整Ｐ--------
'Private Sub Sample_s2( _
'　ByVal lvIdx As Long, _
'　ByVal mnIdx As Long, _
'　ByVal mxIdx As Long, _
'　ByRef o2Ary() As Long, _
'　ByRef tpTbl() As Boolean)

===============================================

以上ご参考まで。長乱文・長乱コード陳謝。

お礼

返信遅くなりました。何度かテストをしましたが、やはりメモリ不足で書き出し準備中と表示をされてしまいました。

これ以上引っ張ってしまいますと本当に申し訳ありませんので、また気になることがありましたらあらためて質問板を立てさせていただきます。

この質問にかかわっていただきました方（特に_Kyleさん、nag0720さん）には本当にお世話になりました。ありがとうございました。

回答No.9

nag0720

Long型に変えたのは、Count変数でしょうか。

Countは組み合わせの総数です。
Integer型は32767までですから、それを超えるならLongにしなければなりません。

このプログラムで一番メモリを使っているのは、TBL(SIZE, 10000)ですが、これはチェック用に行ごとの組み合わせを登録している配列で、TBLCountはその数です。
例えば、質問の図の１０×１０で言えば、１行目の組み合わせの２通りが最大数なので、TBL(SIZE, 2)としても十分です。
132×132の場合でもたぶん１行目の組み合わせが最大になると思いますが、それが10000もいかないならもっと減らしてもいいし、足りなければ増やさなければいけません。
もし処理中に「インデックスが有効範囲にありません」のエラーが出たら、その数をもっと大きくしてください。
TBLCountは、その数が32767を超えなければIntegerのままで大丈夫です。

Longに変えていいのはCountとTBLCountだけですし、この程度のメモリ消費では処理時間にはそんなに影響はないでしょう。

もしこの処理を定期的に行なうのなら、やはりVBAよりVBかCで作ったほうがいいではないでしょうか。
VBAで１時間かかるの処理なら、VBならたぶん５分くらいで終わると思います。Cならもっと速いかもしれません。
VB、Cのコンパイラは両方とも無償でダウンロードできます。

お礼

アドバイスありがとうございます。評価だけは先に入れさせていただきましたが、返信ができていませんでした。

C言語は昔使ったことがあり、コンパイラのDLもできましたが、当然にこのようなプログラムを私に組むことができないために本当に図々しいことは承知しているのですが、お時間があるときにプログラムを教えていただいたら幸いです。

ちなみに、上述のプログラムを１１２×１１２で動かしてみますと１の入っているセルのパターンによって1時間程度で終わる場合もあれば、5,6時間動かしても完了しない場合があります。C言語が早く処理ができるならば、プログラムがどのような動きをするのかも興味があります。

可能でしたらお付き合いいただけるとありがたいです。よろしくお願いします。

回答No.8

nag0720

しつこいですが、再々訂正

＃６のプログラムでまだ時間が掛かるようでしたら、次の箇所を修正してください（追加４箇所、変更３箇所）。

・・・・・・・・・・・・
Dim TBL(SIZE, 10000) As Boolean
Dim TBLCount As Integer ' -------------------------- 追加
Dim Count As Integer
・・・・・・・・・・・・

Sub Combination()
・・・・・・・・・・・・
Count = 0
For i = 1 To SIZE - 1
TBLCount = 0' ------------------------------------ 追加
TCount = 0
・・・・・・・・・・・・
End Sub

Sub AddCombin(n As Integer, k As Integer)
・・・・・・・・・・・・
If n = 1 Or ExistNext Then Exit Sub

' --------------------------------------------- ここから１０行追加
For j = 1 To S(1) - 1
CheckFlag = True
For i = 1 To n
If Not C(j, S(i)) Then
CheckFlag = False
Exit For
End If
Next
If CheckFlag Then Exit Sub
Next
' -------------------------------------------- ここまで

SS = ""
For i = 1 To n
SS = SS & " " & S(i)
Next
Application.StatusBar = "処理中:" & SS

For j = 1 To TBLCount ' ------------------------- 変更
CheckFlag = True
For i = 1 To n
・・・・・・・・・・・・・
Next

TBLCount = TBLCount + 1 ' ----------------------- 追加
Count = Count + 1
For j = 1 To SIZE
TBL(j, TBLCount) = False ' ----------------------- 変更
Next
For i = 1 To n
TBL(S(i), TBLCount) = True ' --------------------- 変更
Worksheets("Sheet2").Cells(Count + 1, i + 1) = S(i)
Next
Worksheets("Sheet2").Cells(Count + 1, 2).Select
End Sub

なお、＃６のプログラムは１００×１００の場合の検証はできていません。
もしかするとバグがあるかもしれませんので、結果がでても御自分で確認してください。

お礼

お礼が遅くなりました。改めてありがとうございます。
132×132の表で１の値が入っているセルが3,878で試しましたら、約1時間程度で出力ができました。
以下にいくつか教えていただければと思い、記載させていただきます。

・一度目の出力で、オーバーフローで型をintからlongに変えまして、2度目の出力で完了しました。ただ、intからlongに変えてメモリを消費するなどやはり注意した方がよろしいでしょうか？

・１の値を入れるセルを変えると、プログラムを動かしても止まる場合があるのですが、注意点などありましたらアドバイスをいただければと思います。

当然に今までのご回答でベストアンサーなのですが、締め切られてしまいますのでもう少しお付き合い頂ければ幸いです。よろしくお願いします。

回答No.7

nag0720

再訂正

＃６のプログラムの
Sub AddCombin(n As Integer, k As Integer)
の中の７行目の
For i = 1 To n
を
For i = 2 To n
にしてください。

お礼

訂正ありがとうございます。確認いたしました。

回答No.6

nag0720

訂正です。
たいした違いはないとは思うけれど、こっちのほうが少し速くなるかもしれません。

Option Explicit
Option Base 1

Const SIZE = 10
Dim C(SIZE, SIZE) As Boolean
Dim TBL(SIZE, 10000) As Boolean
Dim Count As Integer
Dim S(SIZE) As Integer
Dim T(SIZE) As Integer
Dim TCount As Integer
Dim SS As String

Sub Combination()
Dim i As Integer, j As Integer

For i = 1 To SIZE - 1
For j = i + 1 To SIZE
C(i, j) = Cells(i + 1, j + 1)
Next
Next

Worksheets("Sheet2").Select
Count = 0
For i = 1 To SIZE - 1
TCount = 0
For j = i + 1 To SIZE
If C(i, j) Then
TCount = TCount + 1
T(TCount) = j
End If
Next
S(1) = i
AddCombin 1, 1
S(1) = 0
Next
Application.StatusBar = "完了"
End Sub

Sub AddCombin(n As Integer, k As Integer)
Dim i As Integer, j As Integer
Dim ExistNext As Boolean, CheckFlag As Boolean

ExistNext = False
For j = k To TCount
CheckFlag = True
For i = 1 To n
If Not C(S(i), T(j)) Then
CheckFlag = False
Exit For
End If
Next
If CheckFlag Then
ExistNext = True
S(n + 1) = T(j)
AddCombin n + 1, j + 1
S(n + 1) = 0
End If
Next
If n = 1 Or ExistNext Then Exit Sub

SS = ""
For i = 1 To n
SS = SS & " " & S(i)
Next
Application.StatusBar = "処理中:" & SS

For j = 1 To Count
CheckFlag = True
For i = 1 To n
If Not TBL(S(i), j) Then
CheckFlag = False
Exit For
End If
Next
If CheckFlag Then Exit Sub
Next

Count = Count + 1
For j = 1 To SIZE
TBL(j, Count) = False
Next
For i = 1 To n
TBL(S(i), Count) = True
Worksheets("Sheet2").Cells(Count + 1, i + 1) = S(i)
Next
Worksheets("Sheet2").Cells(Count + 1, 2).Select
End Sub

お礼

ご丁寧にアドバイスをいただきまして本当にありがとうございます。プログラムを動かしてみて、再度ご報告申し上げます。よろしくお願いします。

回答No.5

nag0720

改良版のプログラムです。

１００×１００で実行する場合は、SIZEを100に変更してください。
組み合わせ結果は随時、Sheet2に出力されますので、プログラムの実行はコード画面からではなく、シート画面のツールメニューの「マクロ」から実行してください。
また、シート画面下段のステータスバー領域に途中経過を表示していますから、ステータスバーを表示状態にしておいてください。

スピード重視でコーディングしているので前より速くなっているはずですが、１００×１００ではどのくらい時間が掛かるか見当もつきません。
もしこれでだめだったら、他の言語で作るしかないでしょう。

Option Explicit
Option Base 1

Const SIZE = 10
Dim C(SIZE, SIZE) As Boolean
Dim TBL(SIZE, 10000) As Boolean
Dim Count As Integer
Dim S(SIZE) As Integer
Dim SS As String

Sub Combination()
Dim i As Integer, j As Integer

For i = 1 To SIZE - 1
For j = i + 1 To SIZE
C(i, j) = Cells(i + 1, j + 1)
Next
Next

Worksheets("Sheet2").Select
Count = 0
For i = 1 To SIZE - 1
S(1) = i
AddCombin 1, i
S(1) = 0
Next
Application.StatusBar = "完了"
End Sub

Sub AddCombin(n As Integer, k As Integer)
Dim i As Integer, j As Integer
Dim ExistNext As Boolean, CheckFlag As Boolean

ExistNext = False
For j = k + 1 To SIZE
CheckFlag = True
For i = 1 To n
If Not C(S(i), j) Then
CheckFlag = False
Exit For
End If
Next
If CheckFlag Then
ExistNext = True
S(n + 1) = j
AddCombin n + 1, j
S(n + 1) = 0
End If
Next
If n = 1 Or ExistNext Then Exit Sub

SS = ""
For i = 1 To n
SS = SS & " " & S(i)
Next
Application.StatusBar = "処理中:" & SS

For j = 1 To Count
CheckFlag = True
For i = 1 To n
If Not TBL(S(i), j) Then
CheckFlag = False
Exit For
End If
Next
If CheckFlag Then Exit Sub
Next

Count = Count + 1
For j = 1 To SIZE
TBL(j, Count) = False
Next
For i = 1 To n
TBL(S(i), Count) = True
Worksheets("Sheet2").Cells(Count + 1, i + 1) = S(i)
Next
Worksheets("Sheet2").Cells(Count + 1, 2).Select
End Sub

回答No.4

nag0720

＃３です。

＃３のコードは、あまり時間をかけずに雑に作ってしまいましたので、
もう少し分かりやすいコードにしてみました。
配列の使い方が少し違いますが、基本的なアルゴリズムは同じです。

Sub test()
Const SIZE = 10
Dim S(SIZE) As Integer
Dim TBL(SIZE, 1000) As Integer

n = 0
For i = 1 To SIZE - 1
S(i) = 1
For j = i + 1 To SIZE
S(j) = Cells(i + 1, j + 1)
Next

Do
m = 0
For j = i + 1 To SIZE
If S(j) > 0 Then m = m + 1
Next
If m = 0 Then Exit Do

p = 0
For j = i + 1 To SIZE - 1
If S(j) > 0 Then
For k = j + 1 To SIZE
If S(k) > 0 And Cells(j + 1, k + 1) > 0 Then p = p + 1
Next
End If
Next
If p < m * (m - 1) / 2 Then m = 0

If m > 0 Then
For k = 1 To n
p = 0
For j = i To SIZE
If S(j) > 0 And TBL(j, k) > 0 Then p = p + 1
Next
If p = m + 1 Then
m = 0
Exit For
End If
Next
If m > 0 Then
n = n + 1
k = 0
For j = i To SIZE
TBL(j, n) = S(j)
If TBL(j, n) > 0 Then
k = k + 1
Worksheets("Sheet2").Cells(n + 1, k + 1) = j
End If
Next
End If
End If

For j = SIZE To i + 1 Step -1
If Cells(i + 1, j + 1) > 0 Then
If S(j) > 0 Then
S(j) = 0
Exit For
Else
S(j) = Cells(i + 1, j + 1)
End If
End If
Next
Loop
Next
End Sub

＞ちなみに、今回は10行×10列ですが、これが100行×100列になる場合や左図の表の中の値１が多くなると、
＞プログラム開始から終了までの時間は長くなりますか？

このプログラムは、行ごとに総当たり法で１がある列の全ても組み合わせを調べてます。
100行×100列になるだけなら、処理時間は行数×列数に比例するだけですが、
１行の中の１の値が多くなると、処理時間は指数関数的に増大します。

ただ、たいした計算はやっていないのでそんなに処理時間は掛からないとは思いますが、
実際はやってみないと分かりません。
どうしても我慢できないほど時間が掛かるようでしたら、エクセルのVBAではなく、
VisualBasicやＣなどのコンパイラ言語で書いたほうがいいかもしれません。

他の方法として、総当たり法ではなく、再帰的アルゴリズムを使って効率よく組み合わせを調べる方法もあります。
今はあまり時間がないので作るのに少し日数が必要ですが、興味があるなら作ってみましょうか？

お礼

アドバイスありがとうございます。実際に１００×１００で、１が入っているセルが約９００程あるのですが、VBAを動かしてみますと応答なしになってしまいます。時間が経つと結果は出るような気がしますが・・・という状況です。

もしよろしければ効率よく組み合わせを調べるプログラムがあると幸いです。何かとご面倒をおかけしますが、ご助力頂けますと幸いです。

あらためてよろしくお願いします。

回答No.3

nag0720

きれいなコードではないですが、次のようになります。

Sub test()
Dim TBL1(10) As Integer
Dim TBL2(10) As Integer

n = 0
For i = 1 To 9
m = 0
TBL1(m) = i
TBL2(m) = i
For j = i + 1 To 10
If Cells(i + 1, j + 1) = 1 Then
m = m + 1
TBL1(m) = j
TBL2(m) = j
End If
Next
Do
Flag = False
For k = 1 To m
If TBL2(k) > 0 Then
Flag = True
Exit For
End If
Next
If Not Flag Then Exit Do

Flag = True
For k1 = 1 To m - 1
For k2 = k1 + 1 To m
If TBL2(k1) > 0 And TBL2(k2) > 0 Then
If Cells(TBL2(k1) + 1, TBL2(k2) + 1) = 0 Then
Flag = False
Exit For
End If
End If
Next
If Not Flag Then Exit For
Next

If Flag Then
For p = 1 To n
Flag2 = True
For k = 0 To m
If TBL2(k) > 0 Then
Flag3 = False
For j = 1 To Worksheets("Sheet2").Cells(p + 1, 1)
If Worksheets("Sheet2").Cells(p + 1, j + 1) = TBL2(k) Then
Flag3 = True
Exit For
End If
Next
If Not Flag3 Then
Flag2 = False
Exit For
End If
End If
Next
If Flag2 Then
Flag = False
Exit For
End If
Next
End If

If Flag Then
n = n + 1
j = 0
For k = 0 To m
If TBL2(k) > 0 Then
j = j + 1
Worksheets("Sheet2").Cells(n + 1, j + 1) = TBL2(k)
End If
Next
Worksheets("Sheet2").Cells(n + 1, 1) = j
End If

k = m
Do While k > 0
If TBL2(k) > 0 Then
TBL2(k) = 0
Exit Do
Else
TBL2(k) = TBL1(k)
k = k - 1
If k <= 0 Then Exit Do
End If
Loop
Loop
Next
For p = 1 To n
Worksheets("Sheet2").Cells(p + 1, 1) = ""
Next
End Sub

なお、Sheet2のA列を作業用に使用しています。（最後に消去しています）
もしA列が使えない場合は他の列に変更してください。

結果は、
1　2　5　7
1　5　7　8
3　7
4　5　7
5　8　10
7　8　9
となりました。

質問の図の右側の結果には「1　5　7　8」と「5　8　10」がありませんが、これは組み合わせとして成立していないんでしょうか？

お礼

ご回答いただきましてありがとうございました。
質問の「5　8　10」がありませんが、これは組み合わせとして成立していないんでしょうか？
というものですが、成立します。目で追ってると抜け落ちてしまうところがありました。

ちなみに、今回は10行×10列ですが、これが100行×100列になる場合や左図の表の中の値１が多くなると、プログラム開始から終了までの時間は長くなりますか？アドバイスいただけますとありがたいです。

回答No.2

tom04

No.1です。
お礼欄を読みました。

左の表から右の表のようなデータを引き出したい！というコトですが・・・
いくら画像とにらめっこしても
左の表から右の表への規則性が判りません。

当方の解釈では↓の画像のような感じの規則性しか見当たらないのですが、
とりあえずコードを載せてみます。
今回もSheet1のSheetマクロです。

Sub test2()
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
ws.Cells.ClearContents
For i = 2 To 11
If WorksheetFunction.Count(Rows(i)) > 1 Then
ws.Cells(Rows.Count, 2).End(xlUp).Offset(1) = Cells(i, 1)
End If
For j = 2 To 11
If Cells(i, j) = 1 Then
k = ws.Cells(Rows.Count, 2).End(xlUp).Row
ws.Cells(k, Columns.Count).End(xlToLeft).Offset(, 1) = Cells(1, j)
End If
Next j
Next i
ws.Activate
End Sub

※　今回も外していたらごめんなさいね。m（_ _）m

お礼

再度のアドバイスありがとうございます。
Sheet2の２行目の場合は、1 2 5 7 8 と表示されているため、Sheet1の表の
（１行，２列）、（１行，５列）、（１行，７列）、（１行，８列）、（２行，５列）、（２行，７列）、（２行，８列）、（５行，７列）、（５行，８列）、（７行，８列）の所に全て１の値が入力されているということなのですが、（２行，８列）のところに１がないために、Sheet2の２行目の場合は、８を除いた1 2 5 7が表示されるというわけです。

Sheet2の6行目は5 7 8 10とありますが（７行，１０列）のところに１がないために、Sheet2の２行目の場合は、10を除いた5 7 8が表示されるというわけです。

Sheet2の8行目は8 9 10とありますが（９行，１０列）のところに１がないために、Sheet2の２行目の場合は、10を除いた8 9が表示されるというわけです。

ご理解いただき、改めてアドバイスいただけますと幸いです。よろしくお願いします。

回答No.1

tom04

こんにちは！
一例です。

アップされている、左側の画像がSheet1で右側がSheet2だとします。

（1）Sheet1のA列および1行目は1～10の数値が入っている。
（2）Sheet2は画像通り、B2セル以降に数値が入っている。
という前提です。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub test() 'この行から
Dim i As Long, j As Long, k As Long, L As Long, M As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
Range(Cells(2, 2), Cells(11, 11)).ClearContents
For i = 2 To ws.Cells(Rows.Count, 2).End(xlUp).Row
If WorksheetFunction.Count(ws.Rows(i)) > 1 Then
For j = 2 To ws.Cells(i, Columns.Count).End(xlToLeft).Column - 1
For k = j + 1 To ws.Cells(i, Columns.Count).End(xlToLeft).Column
L = WorksheetFunction.Match(ws.Cells(i, j), Columns(1), False)
M = WorksheetFunction.Match(ws.Cells(i, k), Rows(1), False)
Cells(L, M) = 1
Next k
Next j
End If
Next i
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

お礼

丁寧なご回答ありがとうございました。右側の画像から左の画像を出力するためのプログラムを教えていただいたのですが、左側のデータが与えられている場合に、右側のデータを出力するためにどのようにしたらいいか困っている状況です。
よろしければアドバイスいただけますと幸いです。よろしくお願いします。