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

質問

• 共通の値を持つ座標の組み合わせを表示するVBAの作成方法について考えています。
• 表の特定の座標に共通の値を持つ組み合わせを表示するVBAを作成したいです。
• VBAに詳しい方からのアドバイスを頂けると助かります。

回答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番のコメントのお礼にてコメントさせていただきます。