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

質問

左図のような表があるときに、共通の値"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.19

_Kyle

#11,13,15-18です。お待たせしました。

>補足のような形で出力されますと、
>データが見やすくて助かります。

とのことですが、
「補足」というのは質問文の添付画像のことでしょうか？
「書出しの形式はこれまで通りで」ということですよね？

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

Sample_18の書出Ｐ(Sub Sample_d)を
以下のように差し替えてください。
　※書出Ｐの下のソートＰ（Sub Sample_s）はそのままで。
　※プロシージャが１つ増えますのでご注意。

・100万件キッカリで折り返します。
・次のセットとの境界列を赤で塗潰します。

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

なお「1000件で折り返し」等の設定で一応動作確認はしましたが
結果が100万件以上のケースではテストしていません。

メモリあるいは処理能力の点でキビシイようであれば
やはり、C等のコンパイラ言語によるテキストファイル書出しを
検討された方が良いかと思います。

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

'　 'ヒット-----
'　 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)

　'宣言------------
　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

　'出順調整--------
　ReDim o2Ary(rtCnt)
　For i = 1 To rtCnt
　　o2Ary(i) = i
　Next i
　Call Sample_s2(1, 1, rtCnt, o2Ary, tpTbl)

　'書出------------
　Application.Calculation = xlCalculationManual
　Application.ScreenUpdating = False
　With rtSht
　　.Select
　　.Cells.Clear
　End With

　'◆折り返し行数
　mxRow = 1000000

　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

　　rtSht.Cells(1, 1).Offset(0, m * (mxCnt + 1)) _
　　　.Resize(mxRow, mxCnt).Value = dpAry

　　'◆境界列塗潰し
　　rtSht.Columns((m + 1) * (mxCnt + 1)) _
　　　.Interior.Color = vbRed
　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)

　Dim tpVrb　　 As Long
　Dim i　　　　 As Long
　Dim j　　　　 As Long

　If mnIdx >= mxIdx Then Exit Sub

　i = mnIdx - 1
　j = mxIdx + 1

　Do
　　Do
　　　i = i + 1
　　　If i = mxIdx Then Exit Do
　　Loop While tpTbl(o2Ary(i), lvIdx) = True
　　Do
　　　j = j - 1
　　　If j = mnIdx Then Exit Do
　　Loop While tpTbl(o2Ary(j), lvIdx) = False

　　If j <= i Then Exit Do
　　tpVrb = o2Ary(i)
　　o2Ary(i) = o2Ary(j)
　　o2Ary(j) = tpVrb
　Loop

　If Not tpTbl(o2Ary(i), lvIdx) Then i = i - 1
　If mnIdx < i And i <= mxIdx Then
　　Call Sample_s2(lvIdx + 1, mnIdx, i, o2Ary, tpTbl)
　End If

　j = i + 1
　If mnIdx <= j And j < mxIdx Then
　　Call Sample_s2(lvIdx + 1, j, mxIdx, o2Ary, tpTbl)
　End If

End Sub

'-----↑サシカエ↑-----------------------------------------

''ソート------------
'Private Sub Sample_s( _
'　ByVal lvIdx As Long, _
'　ByVal lvOdr As Long, _
'　ByVal mnIdx As Long, _
'　ByVal mxIdx As Long)

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

お礼

ありがとうございます。本日試してみようと思いましたが、完全に試すことができていないです。ただ、仕切りの赤ラインが出力されるのはさらに見やすくなっていまして助かっております。明日あたり実験してみたいと思います。いろいろ分かったこと、伺いたいことがありましたら補足欄にて書き込みさせていただきます。様々アドバイスをいただきまして本当に助かっております。

補足

実験をしてみました。２００×２００の場合でやってみましたが、メモリ不足と表示されてしまいました。検索後→メモリ不足と表示→ステータスバーの『書き出し中』となって終わりました。
一時的なメモリ軽減の操作（システム構成のユーティリティのサービスやスタートアップの無効化など）も行い実験しましたが、メモリ不足の表示が出てしまいました。

私の使っているノートPCのメモリが約２GBで、これが例えば４GBなどメモリが増えればのPCなどになると状況は変わりそうでしょうか？また、パソコンの問題ではないのでしょうか？

改めてアドバイスを頂けますとありがたいです。よろしくお願いします。

回答No.18

_Kyle

#11,13,15-17　です。

パターンが100万件超のケースですか。(＠_＠;)

もはやExcelで扱う世界ではない気もしますが…(^^;;;;;;;

---------------------------------
さて。

結果の書き出し方について
何点か補足をお願いします。
----------
■１

現状で、結果を
　1,2,5,7
　3,7
のように左詰で書き出すようにしていますが
これは
　1,2, , ,5, ,7, , ,
　 , ,3, , , ,7, , ,
のように元位置に応じて書き出す仕様でもOKですか？
----------
■２

現状では、結果の書き出す際
　１を使うパターンを優先
　２を使うパターンを優先
　：
　：
という順序で表示していますが
これはバラバラでも、たとえば
　7,8,9
　3,7
　1,2,5,7
　5,8,10
　4,5,7
　1,5,7,8
といった順序でもOKですか？

お礼

早速の返信ありがとうございました。

現在のところ200行×200列で操作をしますと、約60万件のパターンが出力されます。もしさらに行数列数が増えると100万件を超えそうな気がしましたので質問させていただきました。

補足のような形で出力されますと、データが見やすくて助かります。
本当に感謝申し上げます。

回答No.17

_Kyle

#11,13,15,16です。

#16の続きです。
親と同じモジュールに記述してください。

'--------↑ツヅク↑------------------

'チェック----------
Private Sub Sample_c()

　Dim ckFlg As Boolean
　Dim i　　 As Long
　Dim j　　 As Long

　'チェック---
　For i = 1 To psCnt
　　ckFlg = True
　　For j = 1 To rsCnt
　　　If Not dtTbl(ckAry(j), psAry(i)) Then
　　　　ckFlg = False
　　　　Exit For
　　　End If
　　Next j
　　If ckFlg Then Exit Sub
　Next i

　'ヒット-----
　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)

　'宣言-------
　Dim dpTbl() As Variant
　Dim tpTbl() As Boolean
　Dim mxCnt　 As Long
　Dim i　　　 As Long
　Dim j　　　 As Long
　Dim k　　　 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

　'書出配列---
　ReDim dpTbl(rtCnt, mxCnt)
　For i = 1 To rtCnt
　　k = 0
　　For j = 1 To tbSiz
　　　If tpTbl(i, j) Then
　　　　k = k + 1
　　　　dpTbl(i, k) = j
　　　End If
　　Next j
　Next i

　Application.Calculation = xlCalculationManual
　Application.ScreenUpdating = False

　'書出-------
　With rtSht
　　.Select
　　.Cells.ClearContents
　　.Cells(2, 2).Resize(rtCnt, mxCnt).Value = dpTbl
　End With

　'出順調整---
　mxCnt = ((mxCnt - 1) \ 3 + 1) * 3
　With rtSht.Cells(2, 2).Resize(rtCnt, mxCnt)
　　For i = mxCnt To 3 Step -3
　　　.Sort _
　　　　key1:=.Cells(1, i - 2), _
　　　　order1:=xlAscending, _
　　　　key2:=.Cells(1, i - 1), _
　　　　order2:=xlAscending, _
　　　　key3:=.Cells(1, i), _
　　　　order2:=xlAscending
　　Next i
　End With

　Application.Calculation = xlCalculationAutomatic

End Sub

'ソート------------
Private Sub Sample_s( _
　ByVal lvIdx As Long, _
　ByVal lvOdr As Long, _
　ByVal mnIdx As Long, _
　ByVal mxIdx As Long)

　Dim tpVrb　　 As Long
　Dim loCnt　　 As Long
　Dim upCnt　　 As Long
　Dim loIdx　　 As Long
　Dim upIdx　　 As Long
　Dim i　　　　 As Long
　Dim j　　　　 As Long

　If mnIdx >= mxIdx Then Exit Sub

　'両端確定---
　loCnt = tbSiz
　loIdx = mnIdx
　upCnt = 0
　upIdx = mxIdx
　For i = mnIdx To mxIdx
　　If ctAry(odAry(i)) >= upCnt Then
　　　upCnt = ctAry(odAry(i))
　　　upIdx = i
　　End If
　　If ctAry(odAry(i)) <= loCnt Then
　　　loCnt = ctAry(odAry(i))
　　　loIdx = i
　　End If
　Next i

　tpVrb = odAry(mxIdx)
　odAry(mxIdx) = odAry(upIdx)
　odAry(upIdx) = tpVrb

　tpVrb = odAry(mnIdx)
　odAry(mnIdx) = odAry(loIdx)
　odAry(loIdx) = tpVrb

　'ソート-----
　i = mnIdx
　j = mxIdx

　Do
　　Do
　　　i = i + 1
　　　If i = mxIdx Then Exit Do
　　Loop While orTbl(odAry(lvIdx), odAry(i)) = False
　　Do
　　　j = j - 1
　　　If j = mnIdx Then Exit Do
　　Loop While orTbl(odAry(lvIdx), odAry(j)) = True

　　If j <= i Then Exit Do
　　tpVrb = odAry(i)
　　odAry(i) = odAry(j)
　　odAry(j) = tpVrb
　Loop

　'次の階へ---
　i = i - 1
　If mnIdx + 1 < i And i < mxIdx Then
　　Call Sample_s(lvIdx + lvOdr, lvOdr, mnIdx + 1, i)
　End If
　j = j + 1
　If mnIdx < j And j < mxIdx - 1 Then
　　Call Sample_s(lvIdx + lvOdr, lvOdr, j, mxIdx - 1)
　End If

End Sub
'--------↑ココマデ↑------------------

■追記

もし、わたしの回答が、
課題を解決する上でいくらかでもお役に立てたなら
たいへんうれしく思いますが、

「横入り」とか「後出し」の是非はまた別の問題でして^^;;;;
締切りの際は【くれぐれもお間違えのないよう】
重ねてお願いします。　<(_ _)>

お礼

コメントが遅くなりまして申し訳ありません。excel2007が入っているパソコンをしばらくの間使用することができなかったために、プログラムを動かすことができなかったためです。実際にexcel2007にてプログラムを動かしましたら、3分程度で出力ができました。ありがとうございました。

ひょっとしたらこの件で、また伺いたいこっとがあるかもしれません。その場合に改めてアドバイスを頂けますと幸いです。よろしくお願いします。

余談ですがベストアンサーが１件しか選ぶことができないのが、つらいです。

補足

久しぶりに書き込みをします。新たに質問をさせてください。

パターン数がエクセル2007の最大行数である104万8576行を超える場合に、
新たに列を変えて続きを出力させることはできますでしょうか？

返信頂けますとありがたいです。よろしくお願いします。

回答No.16

_Kyle

#11,13,15です。

■>Private anAry(100000)の中の数値

お察しの通り、anAryは解を格納する配列で
100000は格納／出力可能な解の最大件数です。
　※Sample_18ではrtAryに名前が変わってます

ReDim Preserve を使って
解を見つけるたびに拡げていく方法もありますが
速度的に遅いようなので予め最大件数を宣言しています。

■>注意点などあれば

まず
宣言した時点で要素数に応じたメモリを確保するので
大きな数を指定すると「メモリが足りません」
ってExcelに怒られるかもしれません。

それから
シート上に解を表示する仕様ですから
シートの行数以上を指定しても意味ありません。

■>インデックスが有効範囲にありません

解が十万件超ですか。　(@_@)

そういう場合、所要時間の大半が
探索時間ではなく書出時間だと思います。

「VBA⇒セル」の書出しは遅いので、
もし、#10さまのコードで
「C⇒テキスト」の書出しに成功すれば
書出時間の違いだけで逆転するかも、ですね。

■>１の配置を割り振って

試しに書いてみたんですが…
胡乱というより【饂飩】になっちゃいました(T_T)
しかも字数制限に引っ掛かるし　orz

◎事前ソート
◎書出時に並び・出現順を再調整
◎書出時に列数を切り詰めてから貼り付け
◎その他いろいろ

◆150×150／「１」5540コ／ランダム配置／解100493件
の場合で、総所要時間20秒ほどです。(うち書出時間10秒）

なお
「ソート」は元々の配置がランダムな場合には
ほとんど効果がありません。
「極端に時間がかかる場合に、並の時間で探索する」機能です。

以上ご参考まで。超長乱文,超長乱コード陳謝。<(_ _)>

'--------↓ココカラ↓--------
Option Base 1
'Declare Function timeGetTime Lib "winmm.dll" () As Long

'宣言--------------
Const tbSiz As Long = 150

　Private orTbl(tbSiz, tbSiz) As Boolean
　Private dtTbl(tbSiz, tbSiz) As Boolean
　Private rsAry()　　　　　　 As Boolean
　Private ckAry(tbSiz)　　　　As Long
　Private psAry(tbSiz)　　　　As Long
　Private odAry(tbSiz)　　　　As Long
　Private ctAry(tbSiz)　　　　As Long
　Private rtAry(300000)　　　 As Variant
　Private rsCnt　　　　　　　 As Long
　Private rtCnt　　　　　　　 As Long
　Private psCnt　　　　　　　 As Long
'　Private c　　　　　　　　　 As Long
'　Private t(0 To 3)　　　　　 As Long

'親Ｐ--------------
Sub Sample_18()

　'宣言-------
　Dim orSht　　 As Worksheet
　Dim rtSht　　 As Worksheet
　Dim ckFlg　　 As Boolean
　Dim i　　　　 As Long
　Dim j　　　　 As Long
　Dim k　　　　 As Long

　'初期化-----
'　t(0) = timeGetTime
'　c = 0
　Erase orTbl, dtTbl, ckAry, psAry, odAry, ctAry, rtAry
　ReDim rsAry(tbSiz)
　rtCnt = 0
　rsCnt = 0
　psCnt = 0

　Set orSht = Worksheets("Sheet1")　'元表シート
　Set rtSht = Worksheets("Sheet3")　'結果シート

　'読込-------
　For i = 1 To tbSiz - 1
　　For j = i + 1 To tbSiz
　　　orTbl(i, j) = orSht.Cells(i + 1, j + 1).Value = 1
　　　orTbl(j, i) = orTbl(i, j)
　　Next j
　Next i

　'ソート-----
　For i = 1 To tbSiz
　　odAry(i) = i
　　orTbl(i, i) = True
　Next i

　For i = 1 To tbSiz
　　k = 0
　　For j = 1 To tbSiz
　　　If orTbl(i, j) Then k = k + 1
　　Next j
　　ctAry(i) = k
　Next i

　Call Sample_s(tbSiz, -1, 1, tbSiz)
　Call Sample_s(1, 1, 1, tbSiz \ 2)

　'格納-------
　For i = 1 To tbSiz
　　For j = 1 To tbSiz
　　　dtTbl(i, j) = orTbl(odAry(i), odAry(j))
　　Next j
　Next i

　'準備-------
　For i = 1 To tbSiz
　　ckFlg = False
　　For j = 1 To tbSiz
　　　If i <> j And dtTbl(i, j) Then
　　　　ckFlg = True
　　　　Exit For
　　　End If
　　Next j
　　rsAry(i) = ckFlg
　Next i

'　t(1) = timeGetTime

　'探索-------
　Call Sample_r(1, tbSiz)
'　t(2) = timeGetTime

　'書出-------
　If rtCnt > 0 Then Call Sample_d(rtSht)
'　t(3) = timeGetTime

　'終了-------
　Application.StatusBar = False
　Erase orTbl, dtTbl, ckAry, psAry, odAry, ctAry, rtAry, _
　　　　rsAry

'　Debug.Print timeGetTime - t(0), c, rtCnt, t(1) - t(0), _
'　　　　　　　t(2) - t(1), t(3) - t(2)

End Sub

'子Ｐ--------------
Private Sub Sample_r( _
　ByVal stIdx As Long, _
　ByVal edIdx As Long)

'　c = c + 1

　'宣言-------
　Dim tpAry() As Boolean
　Dim tpCnt　 As Long
　Dim nxIdx　 As Long
　Dim lsIdx　 As Long
　Dim ckFlg　 As Boolean
　Dim i　　　 As Long
　Dim j　　　 As Long

　'主処理-----
　For i = stIdx To edIdx
　　If rsAry(i) Then

　　　tpAry = rsAry
　　　rsCnt = rsCnt + 1
　　　tpCnt = psCnt
　　　ckFlg = True
　　　ckAry(rsCnt) = i
　　　nxIdx = tbSiz
　　　lsIdx = 0

　　　'先行き確認
　　　For j = i + 1 To edIdx
　　　　If rsAry(j) Then
　　　　　If dtTbl(i, j) Then
　　　　　　If j < nxIdx Then nxIdx = j
　　　　　　lsIdx = j
　　　　　Else
　　　　　　rsAry(j) = False
　　　　　　ckFlg = False
　　　　　End If
　　　　End If
　　　Next j

　　　'再帰
　　　If lsIdx = 0 Then
　　　　Call Sample_c
　　　Else
　　　　Call Sample_r(nxIdx, lsIdx)
　　　End If

　　　rsAry = tpAry
　　　rsCnt = rsCnt - 1
　　　psCnt = tpCnt
　　　If ckFlg Then Exit Sub
　　　rsAry(i) = False
　　　psCnt = psCnt + 1
　　　psAry(psCnt) = i

　　End If
　Next i

End Sub
'--------↓ツヅク↓------------------

お礼

アドバイスありがとうございました。動かした状況、結果につきましては16番のコメントのお礼にてコメントさせていただきます。

回答No.15

_Kyle

#11,13です。

>質問者さま

ぇっと、拙「Sample_9」は、結果を一気に吐くので
逐次書き出しの「Combination(#10)」に較べて
全体の所要時間こそ違いますが
計算量そのものは再帰数ベースで【８割】ほどで
それほど減っているわけではありません。

また、「ALL１」とかいった特殊なケースを除けば
「左上に１が偏ると時間がかかる」問題は
解決されていません。

参考画像のように事前にソートして
右に寄せてやれば速くなるようですが
その場合、解の並びが変わってしまいます。

　質問文の例だと
　　{1,2,7,5}
　　{1,7,5,8}
　　{10,5,8}
　　{3,7}
　　{4,7,5}
　　{9,7,8}
　のような感じ。

なお、コーディングについては
必ずしもオーソドックスな書き方ではないので
真似しない方が吉です。念のため(^^;;;

それから、ポイントについては
【くれぐれもお間違えのないよう】
よろしくお願いします。
これも一応念のため。(^^;;;;;;;;;;;;;;

以上ご参考まで。長乱文陳謝。

-------------------------
>#14さま

あ、いえ、こちらこそ
先日来、勉強させていただいてます。

わたしの方でも

　Lv.1「既出解との包含関係をチェック」
　Lv.2「付け加えられるものがあればアウト」
　Lv.3「チェック範囲の僅少化」

みたいな感じで
(全然あっさりではなく）進めていたのですが
最悪計算量のこととかあまり考えずに
「#10（≒Sample_8）で十分速くなってるのに…？？？」
なんて思っていたので、目の覚める思いでした。

　Lv.4(?)「後方に影響を与えないものは必ず使う」

で再帰回数そのものを減らすことができたので
浮かれてつい投稿しましたが
あと出しで引っ掻き回すようなことして申し訳ないです。

便乗というわけではありませんが
ご鞭撻いただけましたら幸いです。　<(_ _)>

お礼

アドバイスありがとうございました。動かした状況、結果につきましては16番のコメントのお礼にてコメントさせていただきます。

回答No.14

nag0720

＃１３さんのコードには脱帽です。

＃１０のコードの無駄な組み合わせのチェックが多いという問題点をあっさり解決していますね。
ＶＢのプログラミング作法もあまり詳しくなかったので参考になります。

これならわざわざＣにしなくても短時間で終了するでしょう。

お礼

nag0720さんのコードにも感謝申し上げます。本当にありがたいです。

回答No.13

_Kyle

#11です。

#12さまのおっしゃるとおり、元データの並びによっては
シートに何もなくても時間がかかる場合がありますね。
早合点の怪答で大変失礼いたしました。
----------------------
お詫びというわけでもないんですが
オリジナルコードを。(^^;;;;;;;

まったく胡乱なコードで、
自分でも何やってるのか混乱気味ですが
ダミーデータで何度かテストした感じでは
#12さまのコードと同じ解が返るようです。

※チェックのため
　結果は【Sheet3】に返す仕様にしています。

ご参考まで。長乱コード陳謝。

'--------↓　ココカラ　↓------------------------
Option Base 1
'Declare Function timeGetTime Lib "winmm.dll" () As Long

'宣言----------------------------------
Const mySiz As Long = 150

　Private myDat(mySiz, mySiz) As Boolean
　Private rsAry()　　　　　　 As Boolean
　Private ckAry(mySiz)　　　　As Long
　Private psAry(mySiz)　　　　As Long
　Private anAry(100000)　　　 As Variant
　Private rsCnt　　　　　　　 As Long
　Private rtCnt　　　　　　　 As Long
'　Private c　　　　　　　　　 As Long

'親Ｐ----------------------------------
Sub Sample_9()　　　'←お察しください^^;;;;

　'宣言----------------------
　Dim orSht As Worksheet
　Dim rtSht As Worksheet
　Dim ckFlg As Boolean
　Dim i　　 As Long
　Dim j　　 As Long
　Dim k　　 As Long
'　Dim t　　 As Long

　'初期化--------------------
　Erase myDat, ckAry, anAry, psAry
　ReDim rsAry(mySiz)
　rtCnt = 0
　rsCnt = 0
'　t = timeGetTime
'　c = 0

　Set orSht = Worksheets("Sheet1")　'元表シート
　Set rtSht = Worksheets("Sheet3")　'結果シート

　'読込----------------------
　For i = 1 To mySiz - 1
　　For j = i + 1 To mySiz
　　　myDat(i, j) = orSht.Cells(i + 1, j + 1).Value = 1
　　　myDat(j, i) = myDat(i, j)
　　Next j
　Next i

　'準備----------------------
　For i = 1 To mySiz
　　ckFlg = False
　　For j = 1 To mySiz
　　　If myDat(i, j) Then
　　　　ckFlg = True
　　　　Exit For
　　　End If
　　Next j
　　rsAry(i) = ckFlg
　Next i

　'探索----------------------
　Call Sample_s(0, 0, mySiz)

　'書出----------------------
　If rtCnt > 0 Then
　　Call Sample_d(rtSht)
　End If

　'終了----------------------
　Application.StatusBar = False
　Erase myDat, rsAry, ckAry, anAry, psAry
'　Debug.Print timeGetTime - t, c, rtCnt

End Sub

'子Ｐ----------------------------------
Private Sub Sample_s( _
　ByVal itCnt As Long, _
　ByVal psCnt As Long, _
　ByVal lsCnt As Long _
　)

'　c = c + 1

　'宣言----------------------
　Dim tpAry()　As Boolean
　Dim ckFlg　　As Boolean
　Dim i　　　　As Long
　Dim j　　　　As Long
　Dim k　　　　As Long

　'主処理？------------------
　　'何やってんだか最早自分でも…　orz

　For i = itCnt + 1 To lsCnt
　　If rsAry(i) Then
　　　rsCnt = rsCnt + 1
　　　ckAry(rsCnt) = i
　　　tpAry = rsAry
　　　ckFlg = True
　　　If i < mySiz Then
　　　　k = i + 1
　　　End If
　　　For j = i + 1 To lsCnt
　　　　If rsAry(j) Then
　　　　　If Not myDat(i, j) Then
　　　　　　rsAry(j) = False
　　　　　　ckFlg = False
　　　　　Else
　　　　　　k = j
　　　　　End If
　　　　End If
　　　Next j
　　　Call Sample_s(i, psCnt, k)
　　　rsAry = tpAry
　　　rsCnt = rsCnt - 1
　　　If ckFlg Then Exit Sub
　　　rsAry(i) = False
　　　psCnt = psCnt + 1
　　　psAry(psCnt) = i
　　End If
　Next i

　'チェック------------------
　For i = 1 To psCnt
　　ckFlg = True
　　For j = 1 To rsCnt
　　　If Not myDat(ckAry(j), psAry(i)) Then
　　　　ckFlg = False
　　　　Exit For
　　　End If
　　Next j
　　If ckFlg Then Exit Sub
　Next i

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

End Sub

'書出Ｐ--------------------------------
Private Sub Sample_d(ByRef rtSht As Worksheet)

　'宣言----------------------
　Dim dpAry() As Variant
　Dim i　　　 As Long
　Dim j　　　 As Long
　Dim k　　　 As Long

　ReDim dpAry(rtCnt, mySiz)

　Application.StatusBar = "書き出し中"

　'書出配列------------------
　For i = 1 To rtCnt
　　k = 1
　　rsAry = anAry(i)
　　For j = 1 To mySiz
　　　If rsAry(j) Then
　　　　dpAry(i, k) = j
　　　　k = k + 1
　　　End If
　　Next j
　Next i

　'書出----------------------
　Application.Calculation = xlCalculationManual
　Application.ScreenUpdating = False
　With rtSht
　　rtSht.Cells.ClearContents
　　rtSht.Cells(2, 2).Resize(rtCnt, mySiz).Value = dpAry
　End With
　Application.Calculation = xlCalculationAutomatic

End Sub
'--------↑　ココマデ　↑------------------------

お礼

プログラムコードありがとうございます。

実際に試しましたら、10分程度で終わりました。すごいと感じました。1の数およびパターンによって状況が変わるようですので、回答者様のアドバイスを参考に１の配置を割り振っていこうと思います。

ちなみに、Private anAry(100000)の中の数値を変化させることで出力できる件数が変えられるということでしょうか？

一応Private anAry(200000)にするとインデックスが有効範囲にありませんの表示がなくなったので伺いました。注意点などあれば教えていただけるとありがたいです。

回答No.12

nag0720

＃１１さん、ありがとうございます。

自動再計算はOFFにしておくべきですね。
自分のところのテスト環境しか見ていなかったので、見逃してしまいました。

画面描画の停止は、処理時間にはそんなに影響はないと思いますが、
シート画面からマクロ実行すれば処理過程が見えるので、それが必要なければ画面描画を停止してもいいでしょう。

＃１１さんのテストでは、150×150／「１」の数4952コの場合で、２分程度で終了するとのことですが、
こちらのテストでも同じくらいの時間で終了します。
ただしこれは「１」をランダムに配置した場合ですから、ある程度規則性を持った配置の場合１時間以上掛かることもありえます。
例えば、100×100で、各行の50列以下のセルに「１」を入れた場合、「１」の個数は49×50/2=1225個ですが、
これをエクセルで実行したら、おそらく１日経っても終わらないでしょう。
Ｃでもどのくらい掛かるか想像もつきません。

Ｃで実行してもうまくいかなかったようですが、exeファイルができているのならコンパイルはたぶん問題ないと思います（コンパイルエラーはありませんでしたか）。
あとは、exeと同じフォルダにdata.txtを置いて実行するだけで大丈夫なはずです。
コマンドプロンプトを開いて実行してもいいし、フォルダの画面からダブルクリックで実行してもいいです。

実行したときの状況はどうだったのでしょうか？
・エラーメッセージはでなかったのか
・処理はすぐ終了したのか、ある程度時間が経ってから終了したのか、いくら経っても終了しないのか

ためしに、data.txtを消して、exeだけにして実行してみてください。
エラーメッセージが出たら、data.txtを読みにいっている証拠です。

さらに、data.txtの中身をカラにして、実行してみてください。
カラのout.txtが作成されるはずです。

もしどうしても分からなければ、mainプロシジャの適当な場所に、
printf("step 1\n");
printf("step 2\n");
などを入れて、どこのステップまで実行しているか確認してください（いわゆるデバッグ作業です）。

お礼

返信ありがとうございます。

本日、返信をと思いながら質問板見ましたら、さまざまなアドバイスがありまして、VBAベースで実験をしておりましたので、Cの方ではまだ実験をしていなくて申し訳ありません。Cの方でも実験をやってみて分かったことなどを補足に入力させていただきます。

回答No.11

_Kyle

横から失礼します。

しばらく前から拝見していたのですが
#10さまのVBAコードを手元の環境でテストしたところ
150×150／「１」の数4952コの場合でも
【　２分　】程度で終了するようです。

112×112で約３時間というのは
時間がかかりすぎているように思うのですが
もしかして

【　対象のブックに数式や条件付き書式等があるのでは　】

#10さまのコードの
--------------------------
Sub Combination()
Dim i As Integer, j As Integer

'の下に
'自動再計算をOFF
Application.Calculation = xlCalculationManual
'画面描画を停止
Application.ScreenUpdating = False
--------------------------

--------------------------
AddCombin 1, 1
S(1) = 0
Next

'の下に
'自動再計算をON
Application.Calculation = xlCalculationAutomatic
--------------------------

で速くなったりしませんか？

以上ご参考まで。横入り陳謝。

お礼

返信ありがとうございます。

実際に試してみましたら、やはり止まってしまいました。
ただ、アドバイスをいただける事は本当にありがたいことです。後日にはオリジナルコードも披露いただき感謝申し上げます。

回答No.10

nag0720

＃６～＃８のプログラムにバグがありました。
パブリック変数の初期設定を充分にしていなかったので、エクセルを再起動せずに１の場所だけ変えて再実行してもうまくいかないようです。

バグ修正およびスピードアップした改良版です。

Option Explicit
Option Base 1

Const SIZE = 10
Dim C(SIZE, SIZE) As Boolean
Dim S(SIZE) As Integer
Dim T(SIZE) As Integer
Dim TCount As Integer
Dim Count As Long

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

For i = 1 To SIZE
For j = 1 To SIZE
C(i, j) = 0
Next
Next
For i = 1 To SIZE - 1
For j = i + 1 To SIZE
C(i, j) = Cells(i + 1, j + 1)
C(j, i) = C(i, j)
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
End Sub

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

ExistNext = False
For j = k To TCount
CheckFlag = True
For i = 2 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

j0 = 1
For i0 = 1 To n
For j = j0 To S(i0) - 1
CheckFlag = True
For i = 1 To n
If Not C(S(i), j) Then
CheckFlag = False
Exit For
End If
Next
If CheckFlag Then Exit Sub
Next
j0 = S(i0) + 1
Next

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

これをＣ言語にするとつぎのようになります。

#include <stdio.h>

#define SIZE 10

void add_combin(int n, int k, char c_data[][SIZE], int s_data[], int t_data[], int *pt_count, long int *pcount, FILE *fp) {
int exist_next = 0;
for (int j = k; j < *pt_count; j++) {
int check_flag = 1;
for (int i = 1; i < n; i++) {
if (c_data[s_data[i]][t_data[j]] == 0) {
check_flag = 0;
break;
}
}
if (check_flag == 1) {
exist_next = 1;
s_data[n] = t_data[j];
add_combin(n + 1, j + 1, c_data, s_data, t_data, pt_count, pcount, fp);
s_data[n] = 0;
}
}
if (n == 1 || exist_next == 1) return;

int j0 = 0;
for (int i0 = 0; i0 < n; i0++) {
for (int j = j0; j < s_data[i0]; j++) {
int check_flag = 1;
for (int i = 0; i < n; i++) {
if (c_data[s_data[i]][j] == 0) {
check_flag = 0;
break;
}
}
if (check_flag == 1) return;
}
j0 = s_data[i0] + 1;
}

(*pcount)++;
printf("%d\n", *pcount);
fprintf(fp, "%d", s_data[0] + 1);
for (int i = 1; i < n; i++)
fprintf(fp, " %d", s_data[i] + 1);
fprintf(fp, "\n");
}

void main() {
char c_data[SIZE][SIZE];
int s_data[SIZE];
int t_data[SIZE];
int t_count;
long int count = 0;

char str[256];
FILE *fp;

for (int i = 0; i < SIZE; i++) {
for (int j = 0; j < SIZE; j++)
c_data[i][j] = 0;
c_data[i][i] = 1;
}

fp = fopen("data.txt", "r");
for (int i = 0; i < SIZE - 1; i++) {
fgets(str, 256, fp);
for (int j = i + 1; j < SIZE; j++) {
if (str[j - i - 1] == '1') {
c_data[i][j] = 1;
c_data[j][i] = 1;
}
}
}
fclose(fp);

fp = fopen("out.txt", "w");
for (int i = 0; i < SIZE - 1; i++) {
t_count = 0;
for (int j = i + 1; j < SIZE; j++) {
if (c_data[i][j] == 1)
t_data[t_count++] = j;
}
s_data[0] = i;
add_combin(1, 0, c_data, s_data, t_data, &t_count, &count, fp);
s_data[0] = 0;
}
fclose(fp);
}

セルが使えませんので、表データと組み合わせ結果はファイルになります。
表データは次のようなファイルにしてください。

ファイル名は、data.txt
ファイル内容は、表の右上の三角の領域の部分を、行ごとに0,1をつなげた文字列にしてください。
例えば、質問の図の１０×１０の場合は、
100101100
00101000
0001000
101000
01101
0000
110
11
0
というように、９行のデータファイルになります。
（１１２×１１２の表なら、１１１行のデータファイルになります）

組み合わせ結果はout.txtに出力されます。
実行中はコンソールに件数が表示されます。

上記のプログラムは標準的なＣのコードです。
お使いのコンパイラによっては変更すべき点もあると思いますので、適宜修正してください。

本来なら、エラー処理をしたり、SIZEを可変にしたりすべきでしょうが、長くなるので割愛しています。
必要なら御自分で組み込んでください。

お礼

再度のアドバイスありがとうございます。

上述のＣ言語のコードをVisual Studio 2008のC++、win32コンソールにて入力後、ビルドしましたらexeファイルができました。exeファイルをdosモードで起動data.txtファイルを読み込ませようとしました（方法は、ローカルディスク（D:)にexeファイルおよびdata.txtファイルを入れまして、dosモードにて、d:\>program.exeと入力しました）がout.txtが出力されなくてどのようにすればいいか困ってしまいました。exeファイルの起動方法もしくはexeファイルの作成の工程についてアドバイスをいただけたら幸いです。
（初歩的な質問になりまして申し訳ありません。お時間あるときに教えていただけるとありがたいです）

また、VBAのコードを１１２×１１２で実行しましたら約３時間程度かかりまして処理が完了しました。プログラムのすごさを実感しました。改めてお礼申し上げます。