Excel VBA で行列計算をさせたいのですが、0,1の組み合わせマトリクス表をどうやってループ計

Excel VBA で行列計算をさせたいのですが、0,1の組み合わせマトリクス表をどうやってループ計算させると良いか？悩んでます。
6☓6の表で、行はa,b,c,d,e,f
列は1〜6とします。
つまり各セルにはa1,a2,a3…
という組み合わせ数字が並びます。
その数字それぞれ0,1の組み合わせパターンを作りたいのです。

規則としては、aの1から6のどれかが『1』となれば、次のbはそれ以外が『1』、cも同じくそれ以外…

こんなイメージの組み合わせが720通り出来るのです。

a b c d e f
1 0 0 1 0 0 0
2 1 0 0 0 0 0
3 0 1 0 0 0 0
4 0 0 0 1 0 0
5 0 0 0 0 0 1
6 0 0 0 0 1 0

これを口で言うのは簡単ですが、VBAでやろうとすると、for nextでどう組めばよいのか？なかなかアイデアが浮かびません。
頭の柔らかい人、どうか助けて下さい！宜しくお願いします。

No.4 回答者： yoreyore 回答日時： 2020/10/15 17:58

no.2です。

⑨×⑨をただ、ただ、結果を待っていたら、出来たことは出来ました。

i = 9 ' ～～～　マトリックスの1辺の数の指定　～～～

’　　　　パターン数　　横　　　縦　　　実行時間
④×④　　　　24　　　14　　 　2　　 　0.8秒
⑤×⑤　　　 120　　　11　　 11　　 　1.6秒
⑥×⑥　　　 720　　　10　 　 10　　 　7.0秒
⑦×⑦　　 5,040　　 　 8　　630　　　48.5秒
⑧×⑧　　40,320　　　 7　 5,760　　 435秒
⑨×⑨ 　362,880　　　 7 51,840　　4855秒　何と 81分間でした。
そのまま　Bookを保存したら、99.5MBにもなっていました。

⑨×⑨の順列組合せデータをメモリ上につくるだけ、(シートに結果を表示しない)でも、423秒(7分間)も懸かっています。

ファイルを保存するだけでも、えーと思うほど、時間がかかります。
このような膨大なのは、出来たという実用性は、まったくないですね。

No.3 回答者： goomania 回答日時： 2020/10/14 18:18

この課題は0～5までの数字を使って、六進法で最大6桁の6進数を発生させ、そのうち各桁に必ず0～5を一つづつ含む数値を探すという課題と等しいと思います。

そこで、まず条件にあう6進数を見つけ、それに対応するマトリクス表を表示するマクロを作成してみました。
720通り全てが表示されていると思います。

Sub sample()
Line = 0
For K1 = 0 To 5
For K2 = 0 To 5
For K3 = 0 To 5
For K4 = 0 To 5
For K5 = 0 To 5
For K6 = 0 To 5
str_num = "" & K1 & K2 & K3 & K4 & K5 & K6
If (InStr(str_num, "0") > 0) * (InStr(str_num, "1") > 0) * (InStr(str_num, "2") > 0) * (InStr(str_num, "3") > 0) * (InStr(str_num, "4") > 0) * (InStr(str_num, "5") > 0) Then
Line = Line + 1
Cells(Line, 1).Value = str_num
For n = 1 To 6
For j = 1 To 6
Cells(Line + n, j).Value = 0
Next
If InStr(str_num, "" & (n Mod 6)) > 0 Then Cells(Line + n, InStr(str_num, "" & (n Mod 6))).Value = 1
Next
Line = Line + 7
End If
Next
Next
Next
Next
Next
Next
End Sub

No.2 回答者： yoreyore 回答日時： 2020/10/11 12:08

順列の計算を、図で表現するようなことなのでしょうか。

なさろうという事情の見当がつきませんが、試しに作ってみました。
⑥×⑥＝720のパターン、⑤×⑤＝120のパターン、⑦×⑦＝5,040のパターンをシートに表示するだけです。　やってみたら、⑧×⑧＝40,320パターンまではやってくれましたが、⑨×⑨は私のPCには負荷が大きすぎるのか、出来ませんでした。
マクロは、次の2つです。　
～～～～　メインのマクロ　～～～～
Sub Macro1()
t0 = Timer '　実行時間計測開始
i = 8 ' ～～～　マトリックスの1辺の数の指定　～～～
'　－－－－　マトリックスの数値配列作成　－－－－
Dim aryIn, aryOut, Block, Yy, Yb
ReDim aryIn(i - 1)
For n = 1 To i: aryIn(n - 1) = n: Next
Call permutation(aryIn, aryOut)
' －－ EXCELシートのデータ･書式抹消,行幅列幅を調整,色指定順決定　－－
Dim CLor, CLoW
CLor = Array(34, 38, 19, 15, 7, 44, 4, 27, 2, 22, 33)
CLoW = Split(Join(CLor, vbCrLf) & vbCrLf & Join(CLor, vbCrLf), vbCrLf)
co = UBound(CLor)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Cells.ClearFormats: Cells.ClearContents: Cells.HorizontalAlignment = xlCenter
Columns("A:IP").ColumnWidth = 2.09: Rows("1:20000").RowHeight = 18
' －－－－ EXCELシートにブロック図を作成し,数値配列を表示　－－－－
ir = 1: cy = 1: bc = 0: ii = i + 1
k = WorksheetFunction.Fact(i)
kl = Int(70 / ii): kr = (Int(k / kl) - ((k Mod kl) > 0) * 1): kl = kl * ii
For rr = 0 To kr
Application.StatusBar = rr & "/" & kr
For ll = 1 To kl Step i + 1
Range(Cells(ii * rr + 2, ll + 1), Cells(ii * (rr + 1), ll + i)).Select
Selection.Interior.ColorIndex = CLoW(cy)
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
Selection = 0
For n = 0 To i - 1
Cells(ii * rr + 2, ll).Offset(n, aryOut(n, bc)) = 1
Next
cy = cy + 1: If cy > 10 Then cy = 1
bc = bc + 1: If bc = k Then ll = kl: rr = kr:
Next
cy = (rr + 2) Mod i
Next
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
t1 = Timer - t0
' 　－－－－　　終了のメッセージ表示　　－－－－
MsgBox i & "×" & i & "パターン" & vbCrLf & k & "図" & vbCrLf & _
"横= " & kl / ii & "　縦= " & kr & vbCrLf & t1 & "秒"
End Sub

～～～～　再帰処理で順列のすべての組合せを作るマクロ　～～～～
Public Sub permutation(ByRef aryIn, ByRef aryOut, Optional ByVal i As Long = 0)
Dim j As Long, ix As Long, sTemp, ary
If i < UBound(aryIn) Then
For j = i To UBound(aryIn)
ary = aryIn: sTemp = aryIn(i): aryIn(i) = aryIn(j): aryIn(j) = sTemp
Call permutation(aryIn, aryOut, i + 1)
aryIn = ary
Next
Else
If IsEmpty(aryOut) Or Not IsArray(aryOut) Then
ix = 0: ReDim aryOut(UBound(aryIn), ix)
Else
ix = UBound(aryOut, 2) + 1: ReDim Preserve aryOut(UBound(aryIn), ix)
End If
For j = LBound(aryIn) To UBound(aryIn)
aryOut(j, ix) = aryIn(j)
Next j
End If
End Sub

私のPCで上記のマクロを、1つの標準モジュールに書いて実行したところ、
’　　　　パターン数　　横　　　縦　　　実行時間
④×④　　　　24　　　14　　　2　　　　0.8秒
⑤×⑤　　　 120　　　11　　 11　　　　1.6秒
⑥×⑥　　　 720　　　10　　 10　　　　7.0秒
⑦×⑦　　 5,040　　　 8　　630　　　48.5秒
⑧×⑧　　40,320　　　 7　 5,760　　 435秒
下の図は、⑧×⑧を実行したときです。

この回答へのお礼

すみません、今気が付きました。早速やってみます。8☓8でも充分です。組み合わせの数を変更できるのは素晴らしいですね。本当にありがとうございます。

お礼日時：2020/10/14 20:14

No.1 回答者： tom04 回答日時： 2020/10/06 18:30

こんばんは！

＞こんなイメージの組み合わせが720通り出来るのです。

一気に720通り？を表示するのではなく、
マクロを実行するたびに色々な組み合わせになるようにしてみました。

一例です。

Sub Sample1()
　Dim i As Long
　Dim myRng As Range
　Dim myNum As Long
　Dim myFlg(1 To 6) As Boolean

　　Set myRng = Range("A1:F6")
　　myRng.ClearContents
　　Randomize
　　　For i = 1 To 6
　　　　Do
　　　　　myNum = Int(6 * Rnd + 1)
　　　　Loop Until myFlg(myNum) = False
　　　　　Cells(i, myNum) = 1
　　　　　myFlg(myNum) = True
　　　Next i
　　　'//↑まででA1～F6セル範囲で列に重複なく「1」が表示される//

　　　'//▼空白セルに「0」を代入//
　　　myRng.SpecialCells(xlCellTypeBlanks) = 0
End Sub

※　当方の解釈が違っていたり
お望みの方法でなければごめんなさい。

場合によっては同じ組み合わせになることがあるかも・・・m(_ _)m

この回答へのお礼

この短時間でここまでありがとうございます！
ざっと見ても、きっと期待通りに処理をするような安心感を感じました。
もし同じ結果が出ても、それに対してif文でくくるので大丈夫です。
心から尊敬します。ありがとうございます！

お礼日時：2020/10/06 19:39